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-2023, 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 System.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 arguments 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          --  Open the response file. If not found, fail or report a warning,
 107          --  depending on the value of Ignore_Non_Existing_Files.
 108
 109          FD : constant File_Descriptor := Open_Read (File_Name, Text);
 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
 170          begin
 171             Last := 0;
 172
 173             if End_Of_File then
 174                return;
 175             end if;
 176
 177             loop
 178                Ch := Buffer (Buffer_Cursor);
 179
 180                exit when Ch = ASCII.CR or else
 181                          Ch = ASCII.LF or else
 182                          Ch = ASCII.FF;
 183
 184                Last := Last + 1;
 185                Line (Last) := Ch;
 186
 187                if Last = Line'Last then
 188                   return;
 189                end if;
 190
 191                Buffer_Cursor := Buffer_Cursor + 1;
 192
 193                if Buffer_Cursor > Buffer_Length then
 194                   Get_Buffer;
 195
 196                   if End_Of_File then
 197                      return;
 198                   end if;
 199                end if;
 200             end loop;
 201
 202             loop
 203                Ch := Buffer (Buffer_Cursor);
 204
 205                exit when Ch /= ASCII.HT and then
 206                          Ch /= ASCII.LF and then
 207                          Ch /= ASCII.FF;
 208
 209                Buffer_Cursor := Buffer_Cursor + 1;
 210
 211                if Buffer_Cursor > Buffer_Length then
 212                   Get_Buffer;
 213
 214                   if End_Of_File then
 215                      return;
 216                   end if;
 217                end if;
 218             end loop;
 219          end Get_Line;
 220
 221       --  Start of processing for Recurse
 222
 223       begin
 224          Last_Arg := 0;
 225
 226          if FD = Invalid_FD then
 227             if Ignore_Non_Existing_Files then
 228                return;
 229             else
 230                raise File_Does_Not_Exist;
 231             end if;
 232          end if;
 233
 234          --  Put the response file name on the stack
 235
 236          if First_File = null then
 237             First_File :=
 238               new File_Rec'
 239                 (Name => new String'(File_Name),
 240                  Next => null,
 241                  Prev => null);
 242             Last_File  := First_File;
 243
 244          else
 245             declare
 246                Current : File_Ptr := First_File;
 247
 248             begin
 249                loop
 250                   if Current.Name.all = File_Name then
 251                      raise Circularity_Detected;
 252                   end if;
 253
 254                   Current := Current.Next;
 255                   exit when Current = null;
 256                end loop;
 257
 258                Last_File.Next :=
 259                  new File_Rec'
 260                    (Name => new String'(File_Name),
 261                     Next => null,
 262                     Prev => Last_File);
 263                Last_File := Last_File.Next;
 264             end;
 265          end if;
 266
 267          End_Of_File_Reached := False;
 268          Get_Buffer;
 269
 270          --  Read the response file line by line
 271
 272          Line_Loop :
 273          while not End_Of_File loop
 274             Get_Line;
 275
 276             if Last = Line'Last then
 277                raise Line_Too_Long;
 278             end if;
 279
 280             First_Char := 1;
 281
 282             --  Get each argument on the line
 283
 284             Arg_Loop :
 285             loop
 286                --  First, skip any white space
 287
 288                while First_Char <= Last loop
 289                   exit when Line (First_Char) /= ' ' and then
 290                             Line (First_Char) /= ASCII.HT;
 291                   First_Char := First_Char + 1;
 292                end loop;
 293
 294                exit Arg_Loop when First_Char > Last;
 295
 296                Last_Char := First_Char;
 297                In_String := False;
 298
 299                --  Get the character one by one
 300
 301                Character_Loop :
 302                while Last_Char <= Last loop
 303
 304                   --  Inside a string, check only for '"'
 305
 306                   if In_String then
 307                      if Line (Last_Char) = '"' then
 308
 309                         --  Remove the '"'
 310
 311                         Line (Last_Char .. Last - 1) :=
 312                           Line (Last_Char + 1 .. Last);
 313                         Last := Last - 1;
 314
 315                         --  End of string is end of argument
 316
 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
 343                      --  An opening '"' at the end of the line is an error
 344
 345                      if Line (Last) = '"' then
 346                         raise No_Closing_Quote;
 347
 348                      else
 349                         --  The argument ends with the line
 350
 351                         exit Character_Loop;
 352                      end if;
 353
 354                   elsif Line (Last_Char) = '"' then
 355
 356                      --  Entering a quoted string: remove the '"'
 357
 358                      In_String := True;
 359                      Line (Last_Char .. Last - 1) :=
 360                        Line (Last_Char + 1 .. Last);
 361                      Last := Last - 1;
 362
 363                   else
 364                      --  Outside quoted strings, white space ends the argument
 365
 366                      exit Character_Loop
 367                           when Line (Last_Char + 1) = ' ' or else
 368                                Line (Last_Char + 1) = ASCII.HT;
 369
 370                      Last_Char := Last_Char + 1;
 371                   end if;
 372                end loop Character_Loop;
 373
 374                --  It is an error to not close a quoted string before the end
 375                --  of the line.
 376
 377                if In_String then
 378                   raise No_Closing_Quote;
 379                end if;
 380
 381                --  Add the argument to the list
 382
 383                declare
 384                   Arg : String (1 .. Last_Char - First_Char + 1);
 385                begin
 386                   Arg := Line (First_Char .. Last_Char);
 387                   Add_Argument (Arg);
 388                end;
 389
 390                --  Next argument, if line is not finished
 391
 392                First_Char := Last_Char + 1;
 393             end loop Arg_Loop;
 394          end loop Line_Loop;
 395
 396          Close (FD);
 397
 398          --  If Recursive is True, check for any argument starting with '@'
 399
 400          if Recursive then
 401             Arg := 1;
 402             while Arg <= Last_Arg loop
 403
 404                if Arguments (Arg)'Length > 0 and then
 405                   Arguments (Arg) (1) = '@'
 406                then
 407                   --  Ignore argument '@' with no file name
 408
 409                   if Arguments (Arg)'Length = 1 then
 410                      Arguments (Arg .. Last_Arg - 1) :=
 411                        Arguments (Arg + 1 .. Last_Arg);
 412                      Last_Arg := Last_Arg - 1;
 413
 414                   else
 415                      --  Save the current arguments and get those in the new
 416                      --  response file.
 417
 418                      declare
 419                         Inc_File_Name     : constant String :=
 420                           Arguments (Arg) (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
 439                            if Arguments'Last < New_Last_Arg then
 440                               Last_Arg := Arguments'Last;
 441                               Free (Arguments);
 442
 443                               while Last_Arg < New_Last_Arg loop
 444                                  Last_Arg := Last_Arg * 2;
 445                               end loop;
 446
 447                               Arguments := new Argument_List (1 .. Last_Arg);
 448                            end if;
 449
 450                            Last_Arg := New_Last_Arg;
 451
 452                            Arguments (1 .. Last_Arg) :=
 453                              Current_Arguments (1 .. Arg - 1) &
 454                            New_Arguments &
 455                            Current_Arguments
 456                              (Arg + 1 .. Current_Arguments'Last);
 457
 458                            Arg := Arg + New_Arguments'Length;
 459                         end;
 460                      end;
 461                   end if;
 462
 463                else
 464                   Arg := Arg + 1;
 465                end if;
 466             end loop;
 467          end if;
 468
 469          --  Remove the response file name from the stack
 470
 471          if First_File = Last_File then
 472             System.Strings.Free (First_File.Name);
 473             Free (First_File);
 474             First_File := null;
 475             Last_File := null;
 476
 477          else
 478             System.Strings.Free (Last_File.Name);
 479             Last_File := Last_File.Prev;
 480             Free (Last_File.Next);
 481          end if;
 482
 483       exception
 484          when others =>
 485             Close (FD);
 486
 487             raise;
 488       end Recurse;
 489
 490    --  Start of processing for Arguments_From
 491
 492    begin
 493       --  The job is done by procedure Recurse
 494
 495       Recurse (Response_File_Name);
 496
 497       --  Free Arguments before returning the result
 498
 499       declare
 500          Result : constant Argument_List := Arguments (1 .. Last_Arg);
 501       begin
 502          Free (Arguments);
 503          return Result;
 504       end;
 505
 506    exception
 507       when others =>
 508
 509          --  When an exception occurs, deallocate everything
 510
 511          Free (Arguments);
 512
 513          while First_File /= null loop
 514             Last_File := First_File.Next;
 515             System.Strings.Free (First_File.Name);
 516             Free (First_File);
 517             First_File := Last_File;
 518          end loop;
 519
 520          raise;
 521    end Arguments_From;
 522
 523 end System.Response_File;