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 the allocated String
  55    --  components.
  56
  57    --------------------
  58    -- Arguments_From --
  59    --------------------
  60
  61    function Arguments_From
  62      (Response_File_Name        : String;
  63       Recursive                 : Boolean := False;
  64       Ignore_Non_Existing_Files : Boolean := False)
  65       return Argument_List
  66    is
  67       First_File : File_Ptr := null;
  68       Last_File  : File_Ptr := null;
  69       --  The stack of response files
  70
  71       Arguments  : Argument_List_Access := new Argument_List (1 .. 4);
  72       Last_Arg   : Natural := 0;
  73
  74       procedure Add_Argument (Arg : String);
  75       --  Add argument Arg to argument list Arguments, increasing Arguments
  76       --  if necessary.
  77
  78       procedure Recurse (File_Name : String);
  79       --  Get the arguments from the file and call itself recursively if
  80       --  one of the argument starts with character '@'.
  81
  82       ------------------
  83       -- Add_Argument --
  84       ------------------
  85
  86       procedure Add_Argument (Arg : String) is
  87       begin
  88          if Last_Arg = Arguments'Last then
  89             declare
  90                New_Arguments : constant Argument_List_Access :=
  91                                  new Argument_List (1 .. Arguments'Last * 2);
  92             begin
  93                New_Arguments (Arguments'Range) := Arguments.all;
  94                Arguments.all := (others => null);
  95                Free (Arguments);
  96                Arguments := New_Arguments;
  97             end;
  98          end if;
  99
 100          Last_Arg := Last_Arg + 1;
 101          Arguments (Last_Arg) := new String'(Arg);
 102       end Add_Argument;
 103
 104       -------------
 105       -- Recurse --
 106       -------------
 107
 108       procedure Recurse (File_Name : String) is
 109          FD : File_Descriptor;
 110
 111          Buffer_Size : constant := 1500;
 112          Buffer : String (1 .. Buffer_Size);
 113
 114          Buffer_Length : Natural;
 115
 116          Buffer_Cursor : Natural;
 117
 118          End_Of_File_Reached : Boolean;
 119
 120          Line : String (1 .. Max_Line_Length + 1);
 121          Last : Natural;
 122
 123          First_Char : Positive;
 124          --  Index of the first character of an argument in Line
 125
 126          Last_Char  : Natural;
 127          --  Index of the last character of an argument in Line
 128
 129          In_String : Boolean;
 130          --  True when inside a quoted string
 131
 132          Arg  : Positive;
 133
 134          function End_Of_File return Boolean;
 135          --  True when the end of the response file has been reached
 136
 137          procedure Get_Buffer;
 138          --  Read one buffer from the response file
 139
 140          procedure Get_Line;
 141          --  Get one line from the response file
 142
 143          -----------------
 144          -- End_Of_File --
 145          -----------------
 146
 147          function End_Of_File return Boolean is
 148          begin
 149             return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
 150          end End_Of_File;
 151
 152          ----------------
 153          -- Get_Buffer --
 154          ----------------
 155
 156          procedure Get_Buffer is
 157          begin
 158             Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
 159             End_Of_File_Reached := Buffer_Length < Buffer'Length;
 160             Buffer_Cursor := 1;
 161          end Get_Buffer;
 162
 163          --------------
 164          -- Get_Line --
 165          --------------
 166
 167          procedure Get_Line is
 168             Ch : Character;
 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
 234             else
 235                raise File_Does_Not_Exist;
 236             end if;
 237          end if;
 238
 239          --  Put the response file name on the stack
 240
 241          if First_File = null then
 242             First_File :=
 243               new File_Rec'
 244                 (Name => new String'(File_Name),
 245                  Next => null,
 246                  Prev => null);
 247             Last_File  := First_File;
 248          else
 249             declare
 250                Current : File_Ptr := First_File;
 251             begin
 252                loop
 253                   if Current.Name.all = File_Name then
 254                      raise Circularity_Detected;
 255                   end if;
 256
 257                   Current := Current.Next;
 258                   exit when Current = null;
 259                end loop;
 260
 261                Last_File.Next :=
 262                  new File_Rec'
 263                    (Name => new String'(File_Name),
 264                     Next => null,
 265                     Prev => Last_File);
 266                Last_File := Last_File.Next;
 267             end;
 268          end if;
 269
 270          End_Of_File_Reached := False;
 271          Get_Buffer;
 272
 273          --  Read the response file line by line
 274
 275          Line_Loop :
 276          while not End_Of_File loop
 277             Get_Line;
 278
 279             if Last = Line'Last then
 280                raise Line_Too_Long;
 281             end if;
 282
 283             First_Char := 1;
 284
 285             --  Get each argument on the line
 286
 287             Arg_Loop :
 288             loop
 289                --  First, skip any white space
 290
 291                while First_Char <= Last loop
 292                   exit when Line (First_Char) /= ' ' and then
 293                             Line (First_Char) /= ASCII.HT;
 294                   First_Char := First_Char + 1;
 295                end loop;
 296
 297                exit Arg_Loop when First_Char > Last;
 298
 299                Last_Char := First_Char;
 300                In_String := False;
 301
 302                --  Get the character one by one
 303
 304                Character_Loop :
 305                while Last_Char <= Last loop
 306                   --  Inside a string, check only for '"'
 307
 308                   if In_String then
 309                      if Line (Last_Char) = '"' then
 310                         --  Remove the '"'
 311
 312                         Line (Last_Char .. Last - 1) :=
 313                           Line (Last_Char + 1 .. Last);
 314                         Last := Last - 1;
 315
 316                         --  End of string is end of argument
 317                         if Last_Char > Last or else
 318                           Line (Last_Char) = ' ' or else
 319                           Line (Last_Char) = ASCII.HT
 320                         then
 321                            In_String := False;
 322
 323                            Last_Char := Last_Char - 1;
 324                            exit Character_Loop;
 325
 326                         else
 327                            --  If there are two consecutive '"', the quoted
 328                            --  string is not closed
 329
 330                            In_String := Line (Last_Char) = '"';
 331
 332                            if In_String then
 333                               Last_Char := Last_Char + 1;
 334                            end if;
 335                         end if;
 336
 337                      else
 338                         Last_Char := Last_Char + 1;
 339                      end if;
 340
 341                   elsif Last_Char = Last then
 342                      --  An opening '"' at the end of the line is an error
 343
 344                      if Line (Last) = '"' then
 345                         raise No_Closing_Quote;
 346
 347                      else
 348                         --  The argument ends with the line
 349
 350                         exit Character_Loop;
 351                      end if;
 352
 353                   elsif Line (Last_Char) = '"' then
 354                      --  Entering a quoted string: remove the '"'
 355
 356                      In_String := True;
 357                      Line (Last_Char .. Last - 1) :=
 358                        Line (Last_Char + 1 .. Last);
 359                      Last := Last - 1;
 360
 361                   else
 362                      --  Outside of quoted strings, white space ends the
 363                      --  argument.
 364
 365                      exit Character_Loop
 366                           when Line (Last_Char + 1) = ' ' or else
 367                                Line (Last_Char + 1) = ASCII.HT;
 368
 369                      Last_Char := Last_Char + 1;
 370                   end if;
 371                end loop Character_Loop;
 372
 373                --  It is an error to not close a quoted string before the end
 374                --  of the line.
 375
 376                if In_String then
 377                   raise No_Closing_Quote;
 378                end if;
 379
 380                --  Add the argument to the list
 381
 382                declare
 383                   Arg : String (1 .. Last_Char - First_Char + 1);
 384                begin
 385                   Arg := Line (First_Char .. Last_Char);
 386                   Add_Argument (Arg);
 387                end;
 388
 389                --  Next argument, if line is not finished
 390
 391                First_Char := Last_Char + 1;
 392             end loop Arg_Loop;
 393          end loop Line_Loop;
 394
 395          Close (FD);
 396
 397          --  If Recursive is True, check for any argument starting with '@'
 398
 399          if Recursive then
 400             Arg := 1;
 401             while Arg <= Last_Arg loop
 402
 403                if Arguments (Arg)'Length > 0 and then
 404                   Arguments (Arg) (1) = '@'
 405                then
 406                   --  Ignore argument "@" with no file name
 407
 408                   if Arguments (Arg)'Length = 1 then
 409                      Arguments (Arg .. Last_Arg - 1) :=
 410                        Arguments (Arg + 1 .. Last_Arg);
 411                      Last_Arg := Last_Arg - 1;
 412
 413                   else
 414                      --  Save the current arguments and get those in the
 415                      --  new response file.
 416
 417                      declare
 418                         Inc_File_Name     : constant String :=
 419                                               Arguments (Arg)
 420                                               (2 .. Arguments (Arg)'Last);
 421                         Current_Arguments : constant Argument_List :=
 422                                               Arguments (1 .. Last_Arg);
 423                      begin
 424                         Recurse (Inc_File_Name);
 425
 426                         --  Insert the new arguments where the new response
 427                         --  file was imported.
 428
 429                         declare
 430                            New_Arguments : constant Argument_List :=
 431                                              Arguments (1 .. Last_Arg);
 432                            New_Last_Arg  : constant Positive :=
 433                                              Current_Arguments'Length +
 434                                              New_Arguments'Length - 1;
 435
 436                         begin
 437                            --  Grow Arguments if it is not large enough
 438                            if Arguments'Last < New_Last_Arg then
 439                               Last_Arg := Arguments'Last;
 440                               Free (Arguments);
 441
 442                               while Last_Arg < New_Last_Arg loop
 443                                  Last_Arg := Last_Arg * 2;
 444                               end loop;
 445
 446                               Arguments := new Argument_List (1 .. Last_Arg);
 447                            end if;
 448
 449                            Last_Arg := New_Last_Arg;
 450
 451                            Arguments (1 .. Last_Arg) :=
 452                              Current_Arguments (1 .. Arg - 1) &
 453                            New_Arguments &
 454                            Current_Arguments
 455                              (Arg + 1 .. Current_Arguments'Last);
 456
 457                            Arg := Arg + New_Arguments'Length;
 458                         end;
 459                      end;
 460                   end if;
 461
 462                else
 463                   Arg := Arg + 1;
 464                end if;
 465             end loop;
 466          end if;
 467
 468          --  Remove the response file name from the stack
 469
 470          if First_File = Last_File then
 471             System.Strings.Free (First_File.Name);
 472             Free (First_File);
 473             First_File := null;
 474             Last_File := null;
 475
 476          else
 477             System.Strings.Free (Last_File.Name);
 478             Last_File := Last_File.Prev;
 479             Free (Last_File.Next);
 480          end if;
 481
 482       exception
 483          when others =>
 484             Close (FD);
 485
 486             raise;
 487       end Recurse;
 488
 489    --  Start of Arguments_From
 490
 491    begin
 492       --  The job is done by procedure Recurse
 493
 494       Recurse (Response_File_Name);
 495
 496       --  Free Arguments before returning the result
 497
 498       declare
 499          Result : constant Argument_List := Arguments (1 .. Last_Arg);
 500       begin
 501          Free (Arguments);
 502          return Result;
 503       end;
 504
 505    exception
 506       when others =>
 507          --  When an exception occurs, deallocate everything
 508
 509          Free (Arguments);
 510
 511          while First_File /= null loop
 512             Last_File := First_File.Next;
 513             System.Strings.Free (First_File.Name);
 514             Free (First_File);
 515             First_File := Last_File;
 516          end loop;
 517
 518          raise;
 519    end Arguments_From;
 520
 521 end Ada.Command_Line.Response_File;