gcc/ada/make_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            M A K E _ U T I L                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-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.  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Debug;
  28 with Errutil;
  29 with Osint;    use Osint;
  30 with Output;   use Output;
  31 with Opt;      use Opt;
  32 with Table;
  33
  34 with Ada.Command_Line;           use Ada.Command_Line;
  35
  36 with GNAT.Case_Util;             use GNAT.Case_Util;
  37 with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
  38 with GNAT.HTable;
  39
  40 package body Make_Util is
  41
  42    ---------
  43    -- Add --
  44    ---------
  45
  46    procedure Add
  47      (Option : String_Access;
  48       To     : in out String_List_Access;
  49       Last   : in out Natural)
  50    is
  51    begin
  52       if Last = To'Last then
  53          declare
  54             New_Options : constant String_List_Access :=
  55                             new String_List (1 .. To'Last * 2);
  56
  57          begin
  58             New_Options (To'Range) := To.all;
  59
  60             --  Set all elements of the original options to null to avoid
  61             --  deallocation of copies.
  62
  63             To.all := (others => null);
  64
  65             Free (To);
  66             To := New_Options;
  67          end;
  68       end if;
  69
  70       Last := Last + 1;
  71       To (Last) := Option;
  72    end Add;
  73
  74    procedure Add
  75      (Option : String;
  76       To     : in out String_List_Access;
  77       Last   : in out Natural)
  78    is
  79    begin
  80       Add (Option => new String'(Option), To => To, Last => Last);
  81    end Add;
  82
  83    -------------------------
  84    -- Base_Name_Index_For --
  85    -------------------------
  86
  87    function Base_Name_Index_For
  88      (Main            : String;
  89       Main_Index      : Int;
  90       Index_Separator : Character) return File_Name_Type
  91    is
  92       Result : File_Name_Type;
  93
  94    begin
  95       Name_Len := 0;
  96       Add_Str_To_Name_Buffer (Base_Name (Main));
  97
  98       --  Remove the extension, if any, that is the last part of the base name
  99       --  starting with a dot and following some characters.
 100
 101       for J in reverse 2 .. Name_Len loop
 102          if Name_Buffer (J) = '.' then
 103             Name_Len := J - 1;
 104             exit;
 105          end if;
 106       end loop;
 107
 108       --  Add the index info, if index is different from 0
 109
 110       if Main_Index > 0 then
 111          Add_Char_To_Name_Buffer (Index_Separator);
 112
 113          declare
 114             Img : constant String := Main_Index'Img;
 115          begin
 116             Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
 117          end;
 118       end if;
 119
 120       Result := Name_Find;
 121       return Result;
 122    end Base_Name_Index_For;
 123
 124    -----------------
 125    -- Create_Name --
 126    -----------------
 127
 128    function Create_Name (Name : String) return File_Name_Type is
 129    begin
 130       Name_Len := 0;
 131       Add_Str_To_Name_Buffer (Name);
 132       return Name_Find;
 133    end Create_Name;
 134
 135    function Create_Name (Name : String) return Name_Id is
 136    begin
 137       Name_Len := 0;
 138       Add_Str_To_Name_Buffer (Name);
 139       return Name_Find;
 140    end Create_Name;
 141
 142    function Create_Name (Name : String) return Path_Name_Type is
 143    begin
 144       Name_Len := 0;
 145       Add_Str_To_Name_Buffer (Name);
 146       return Name_Find;
 147    end Create_Name;
 148
 149    ---------------------------
 150    -- Ensure_Absolute_Path --
 151    ---------------------------
 152
 153    procedure Ensure_Absolute_Path
 154      (Switch               : in out String_Access;
 155       Parent               : String;
 156       Do_Fail              : Fail_Proc;
 157       For_Gnatbind         : Boolean := False;
 158       Including_Non_Switch : Boolean := True;
 159       Including_RTS        : Boolean := False)
 160    is
 161    begin
 162       if Switch /= null then
 163          declare
 164             Sw    : String (1 .. Switch'Length);
 165             Start : Positive;
 166
 167          begin
 168             Sw := Switch.all;
 169
 170             if Sw (1) = '-' then
 171                if Sw'Length >= 3
 172                  and then (Sw (2) = 'I'
 173                             or else (not For_Gnatbind
 174                                       and then (Sw (2) = 'L'
 175                                                  or else
 176                                                 Sw (2) = 'A')))
 177                then
 178                   Start := 3;
 179
 180                   if Sw = "-I-" then
 181                      return;
 182                   end if;
 183
 184                elsif Sw'Length >= 4
 185                  and then
 186                    (Sw (2 .. 3) = "aL" or else
 187                     Sw (2 .. 3) = "aO" or else
 188                     Sw (2 .. 3) = "aI"
 189                       or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
 190                then
 191                   Start := 4;
 192
 193                elsif Including_RTS
 194                  and then Sw'Length >= 7
 195                  and then Sw (2 .. 6) = "-RTS="
 196                then
 197                   Start := 7;
 198
 199                else
 200                   return;
 201                end if;
 202
 203                --  Because relative path arguments to --RTS= may be relative to
 204                --  the search directory prefix, those relative path arguments
 205                --  are converted only when they include directory information.
 206
 207                if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
 208                   if Parent'Length = 0 then
 209                      Do_Fail
 210                        ("relative search path switches ("""
 211                         & Sw
 212                         & """) are not allowed");
 213
 214                   elsif Including_RTS then
 215                      for J in Start .. Sw'Last loop
 216                         if Sw (J) = Directory_Separator then
 217                            Switch :=
 218                              new String'
 219                                (Sw (1 .. Start - 1)
 220                                 & Parent
 221                                 & Directory_Separator
 222                                 & Sw (Start .. Sw'Last));
 223                            return;
 224                         end if;
 225                      end loop;
 226
 227                   else
 228                      Switch :=
 229                        new String'
 230                          (Sw (1 .. Start - 1)
 231                           & Parent
 232                           & Directory_Separator
 233                           & Sw (Start .. Sw'Last));
 234                   end if;
 235                end if;
 236
 237             elsif Including_Non_Switch then
 238                if not Is_Absolute_Path (Sw) then
 239                   if Parent'Length = 0 then
 240                      Do_Fail
 241                        ("relative paths (""" & Sw & """) are not allowed");
 242                   else
 243                      Switch := new String'(Parent & Directory_Separator & Sw);
 244                   end if;
 245                end if;
 246             end if;
 247          end;
 248       end if;
 249    end Ensure_Absolute_Path;
 250
 251    ----------------------------
 252    -- Executable_Prefix_Path --
 253    ----------------------------
 254
 255    function Executable_Prefix_Path return String is
 256       Exec_Name : constant String := Command_Name;
 257
 258       function Get_Install_Dir (S : String) return String;
 259       --  S is the executable name preceded by the absolute or relative path,
 260       --  e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
 261       --  lies (in the example "C:\usr"). If the executable is not in a "bin"
 262       --  directory, return "".
 263
 264       ---------------------
 265       -- Get_Install_Dir --
 266       ---------------------
 267
 268       function Get_Install_Dir (S : String) return String is
 269          Exec      : String  := S;
 270          Path_Last : Integer := 0;
 271
 272       begin
 273          for J in reverse Exec'Range loop
 274             if Exec (J) = Directory_Separator then
 275                Path_Last := J - 1;
 276                exit;
 277             end if;
 278          end loop;
 279
 280          if Path_Last >= Exec'First + 2 then
 281             To_Lower (Exec (Path_Last - 2 .. Path_Last));
 282          end if;
 283
 284          if Path_Last < Exec'First + 2
 285            or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
 286            or else (Path_Last - 3 >= Exec'First
 287                      and then Exec (Path_Last - 3) /= Directory_Separator)
 288          then
 289             return "";
 290          end if;
 291
 292          return Normalize_Pathname
 293                   (Exec (Exec'First .. Path_Last - 4),
 294                    Resolve_Links => Opt.Follow_Links_For_Dirs)
 295            & Directory_Separator;
 296       end Get_Install_Dir;
 297
 298    --  Beginning of Executable_Prefix_Path
 299
 300    begin
 301       --  First determine if a path prefix was placed in front of the
 302       --  executable name.
 303
 304       for J in reverse Exec_Name'Range loop
 305          if Exec_Name (J) = Directory_Separator then
 306             return Get_Install_Dir (Exec_Name);
 307          end if;
 308       end loop;
 309
 310       --  If we get here, the user has typed the executable name with no
 311       --  directory prefix.
 312
 313       declare
 314          Path : String_Access := Locate_Exec_On_Path (Exec_Name);
 315       begin
 316          if Path = null then
 317             return "";
 318          else
 319             declare
 320                Dir : constant String := Get_Install_Dir (Path.all);
 321             begin
 322                Free (Path);
 323                return Dir;
 324             end;
 325          end if;
 326       end;
 327    end Executable_Prefix_Path;
 328
 329    ------------------
 330    -- Fail_Program --
 331    ------------------
 332
 333    procedure Fail_Program
 334      (S              : String;
 335       Flush_Messages : Boolean := True)
 336    is
 337    begin
 338       if Flush_Messages and not No_Exit_Message then
 339          if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
 340             Errutil.Finalize;
 341          end if;
 342       end if;
 343
 344       Finish_Program (E_Fatal, S => S);
 345    end Fail_Program;
 346
 347    --------------------
 348    -- Finish_Program --
 349    --------------------
 350
 351    procedure Finish_Program
 352      (Exit_Code    : Osint.Exit_Code_Type := Osint.E_Success;
 353       S            : String := "")
 354    is
 355    begin
 356       if S'Length > 0 then
 357          if Exit_Code /= E_Success then
 358             if No_Exit_Message then
 359                Osint.Exit_Program (E_Fatal);
 360             else
 361                Osint.Fail (S);
 362             end if;
 363
 364          elsif not No_Exit_Message then
 365             Write_Str (S);
 366          end if;
 367       end if;
 368
 369       --  Output Namet statistics
 370
 371       Namet.Finalize;
 372
 373       Exit_Program (Exit_Code);
 374    end Finish_Program;
 375
 376    ----------
 377    -- Hash --
 378    ----------
 379
 380    function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
 381    --  Used in implementation of other functions Hash below
 382
 383    ----------
 384    -- Hash --
 385    ----------
 386
 387    function Hash (Name : File_Name_Type) return Header_Num is
 388    begin
 389       return Hash (Get_Name_String (Name));
 390    end Hash;
 391
 392    function Hash (Name : Name_Id) return Header_Num is
 393    begin
 394       return Hash (Get_Name_String (Name));
 395    end Hash;
 396
 397    function Hash (Name : Path_Name_Type) return Header_Num is
 398    begin
 399       return Hash (Get_Name_String (Name));
 400    end Hash;
 401
 402    ------------
 403    -- Inform --
 404    ------------
 405
 406    procedure Inform (N : File_Name_Type; Msg : String) is
 407    begin
 408       Inform (Name_Id (N), Msg);
 409    end Inform;
 410
 411    procedure Inform (N : Name_Id := No_Name; Msg : String) is
 412    begin
 413       Osint.Write_Program_Name;
 414
 415       Write_Str (": ");
 416
 417       if N /= No_Name then
 418          Write_Str ("""");
 419
 420          declare
 421             Name : constant String := Get_Name_String (N);
 422          begin
 423             if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
 424                Write_Str (File_Name (Name));
 425             else
 426                Write_Str (Name);
 427             end if;
 428          end;
 429
 430          Write_Str (""" ");
 431       end if;
 432
 433       Write_Str (Msg);
 434       Write_Eol;
 435    end Inform;
 436
 437    -----------
 438    -- Mains --
 439    -----------
 440
 441    package body Mains is
 442
 443       package Names is new Table.Table
 444         (Table_Component_Type => Main_Info,
 445          Table_Index_Type     => Integer,
 446          Table_Low_Bound      => 1,
 447          Table_Initial        => 10,
 448          Table_Increment      => 100,
 449          Table_Name           => "Makeutl.Mains.Names");
 450       --  The table that stores the mains
 451
 452       Current : Natural := 0;
 453       --  The index of the last main retrieved from the table
 454
 455       Count_Of_Mains_With_No_Tree : Natural := 0;
 456       --  Number of main units for which we do not know the project tree
 457
 458       --------------
 459       -- Add_Main --
 460       --------------
 461
 462       procedure Add_Main (Name : String; Index : Int := 0) is
 463       begin
 464          Name_Len := 0;
 465          Add_Str_To_Name_Buffer (Name);
 466          Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 467
 468          Names.Increment_Last;
 469          Names.Table (Names.Last) := (Name_Find, Index);
 470
 471          Mains.Count_Of_Mains_With_No_Tree :=
 472            Mains.Count_Of_Mains_With_No_Tree + 1;
 473       end Add_Main;
 474
 475       ------------
 476       -- Delete --
 477       ------------
 478
 479       procedure Delete is
 480       begin
 481          Names.Set_Last (0);
 482          Mains.Reset;
 483       end Delete;
 484
 485       ---------------
 486       -- Next_Main --
 487       ---------------
 488
 489       function Next_Main return String is
 490          Info : constant Main_Info := Next_Main;
 491       begin
 492          if Info = No_Main_Info then
 493             return "";
 494          else
 495             return Get_Name_String (Info.File);
 496          end if;
 497       end Next_Main;
 498
 499       function Next_Main return Main_Info is
 500       begin
 501          if Current >= Names.Last then
 502             return No_Main_Info;
 503          else
 504             Current := Current + 1;
 505
 506             declare
 507                Orig_Main : constant File_Name_Type :=
 508                  Names.Table (Current).File;
 509                Current_Main : File_Name_Type;
 510
 511             begin
 512                if Strip_Suffix (Orig_Main) = Orig_Main then
 513                   Get_Name_String (Orig_Main);
 514                   Add_Str_To_Name_Buffer (".adb");
 515                   Current_Main := Name_Find;
 516
 517                   if Full_Source_Name (Current_Main) = No_File then
 518                      Get_Name_String (Orig_Main);
 519                      Add_Str_To_Name_Buffer (".ads");
 520                      Current_Main := Name_Find;
 521
 522                      if Full_Source_Name (Current_Main) /= No_File then
 523                         Names.Table (Current).File := Current_Main;
 524                      end if;
 525
 526                   else
 527                      Names.Table (Current).File := Current_Main;
 528                   end if;
 529                end if;
 530             end;
 531
 532             return Names.Table (Current);
 533          end if;
 534       end Next_Main;
 535
 536       ---------------------
 537       -- Number_Of_Mains --
 538       ---------------------
 539
 540       function Number_Of_Mains return Natural is
 541       begin
 542          return Names.Last;
 543       end Number_Of_Mains;
 544
 545       -----------
 546       -- Reset --
 547       -----------
 548
 549       procedure Reset is
 550       begin
 551          Current := 0;
 552       end Reset;
 553
 554       --------------------------
 555       -- Set_Multi_Unit_Index --
 556       --------------------------
 557
 558       procedure Set_Multi_Unit_Index
 559         (Index        : Int := 0)
 560       is
 561       begin
 562          if Index /= 0 then
 563             if Names.Last = 0 then
 564                Fail_Program
 565                  ("cannot specify a multi-unit index but no main "
 566                   & "on the command line");
 567
 568             elsif Names.Last > 1 then
 569                Fail_Program
 570                  ("cannot specify several mains with a multi-unit index");
 571
 572             else
 573                Names.Table (Names.Last).Index := Index;
 574             end if;
 575          end if;
 576       end Set_Multi_Unit_Index;
 577
 578    end Mains;
 579
 580    -----------------------
 581    -- Path_Or_File_Name --
 582    -----------------------
 583
 584    function Path_Or_File_Name (Path : Path_Name_Type) return String is
 585       Path_Name : constant String := Get_Name_String (Path);
 586    begin
 587       if Debug.Debug_Flag_F then
 588          return File_Name (Path_Name);
 589       else
 590          return Path_Name;
 591       end if;
 592    end Path_Or_File_Name;
 593
 594    -------------------
 595    -- Unit_Index_Of --
 596    -------------------
 597
 598    function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
 599       Start  : Natural;
 600       Finish : Natural;
 601       Result : Int := 0;
 602
 603    begin
 604       Get_Name_String (ALI_File);
 605
 606       --  First, find the last dot
 607
 608       Finish := Name_Len;
 609
 610       while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
 611          Finish := Finish - 1;
 612       end loop;
 613
 614       if Finish = 1 then
 615          return 0;
 616       end if;
 617
 618       --  Now check that the dot is preceded by digits
 619
 620       Start := Finish;
 621       Finish := Finish - 1;
 622       while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
 623          Start := Start - 1;
 624       end loop;
 625
 626       --  If there are no digits, or if the digits are not preceded by the
 627       --  character that precedes a unit index, this is not the ALI file of
 628       --  a unit in a multi-unit source.
 629
 630       if Start > Finish
 631         or else Start = 1
 632         or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
 633       then
 634          return 0;
 635       end if;
 636
 637       --  Build the index from the digit(s)
 638
 639       while Start <= Finish loop
 640          Result := Result * 10 +
 641                      Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
 642          Start := Start + 1;
 643       end loop;
 644
 645       return Result;
 646    end Unit_Index_Of;
 647
 648    -----------------
 649    -- Verbose_Msg --
 650    -----------------
 651
 652    procedure Verbose_Msg
 653      (N1                : Name_Id;
 654       S1                : String;
 655       N2                : Name_Id := No_Name;
 656       S2                : String  := "";
 657       Prefix            : String := "  -> ";
 658       Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
 659    is
 660    begin
 661       if not Opt.Verbose_Mode
 662         or else Minimum_Verbosity > Opt.Verbosity_Level
 663       then
 664          return;
 665       end if;
 666
 667       Write_Str (Prefix);
 668       Write_Str ("""");
 669       Write_Name (N1);
 670       Write_Str (""" ");
 671       Write_Str (S1);
 672
 673       if N2 /= No_Name then
 674          Write_Str (" """);
 675          Write_Name (N2);
 676          Write_Str (""" ");
 677       end if;
 678
 679       Write_Str (S2);
 680       Write_Eol;
 681    end Verbose_Msg;
 682
 683    procedure Verbose_Msg
 684      (N1                : File_Name_Type;
 685       S1                : String;
 686       N2                : File_Name_Type := No_File;
 687       S2                : String  := "";
 688       Prefix            : String := "  -> ";
 689       Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
 690    is
 691    begin
 692       Verbose_Msg
 693         (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
 694    end Verbose_Msg;
 695
 696    -----------
 697    -- Queue --
 698    -----------
 699
 700    package body Queue is
 701
 702       type Q_Record is record
 703          Info      : Source_Info;
 704          Processed : Boolean;
 705       end record;
 706
 707       package Q is new Table.Table
 708         (Table_Component_Type => Q_Record,
 709          Table_Index_Type     => Natural,
 710          Table_Low_Bound      => 1,
 711          Table_Initial        => 1000,
 712          Table_Increment      => 100,
 713          Table_Name           => "Makeutl.Queue.Q");
 714       --  This is the actual Queue
 715
 716       type Mark_Key is record
 717          File  : File_Name_Type;
 718          Index : Int;
 719       end record;
 720       --  Identify either a mono-unit source (when Index = 0) or a specific
 721       --  unit (index = 1's origin index of unit) in a multi-unit source.
 722
 723       Max_Mask_Num : constant := 2048;
 724       subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
 725
 726       function Hash (Key : Mark_Key) return Mark_Num;
 727
 728       package Marks is new GNAT.HTable.Simple_HTable
 729         (Header_Num => Mark_Num,
 730          Element    => Boolean,
 731          No_Element => False,
 732          Key        => Mark_Key,
 733          Hash       => Hash,
 734          Equal      => "=");
 735       --  A hash table to keep tracks of the marked units.
 736       --  These are the units that have already been processed, when using the
 737       --  gnatmake format. When using the gprbuild format, we can directly
 738       --  store in the source_id whether the file has already been processed.
 739
 740       procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
 741       --  Mark a unit, identified by its source file and, when Index is not 0,
 742       --  the index of the unit in the source file. Marking is used to signal
 743       --  that the unit has already been inserted in the Q.
 744
 745       function Is_Marked
 746         (Source_File : File_Name_Type;
 747          Index       : Int := 0) return Boolean;
 748       --  Returns True if the unit was previously marked
 749
 750       Q_Processed   : Natural := 0;
 751       Q_Initialized : Boolean := False;
 752
 753       Q_First : Natural := 1;
 754       --  Points to the first valid element in the queue
 755
 756       procedure Debug_Display (S : Source_Info);
 757       --  A debug display for S
 758
 759       function Was_Processed (S : Source_Info) return Boolean;
 760       --  Whether S has already been processed. This marks the source as
 761       --  processed, if it hasn't already been processed.
 762
 763       -------------------
 764       -- Was_Processed --
 765       -------------------
 766
 767       function Was_Processed (S : Source_Info) return Boolean is
 768       begin
 769          if Is_Marked (S.File, S.Index) then
 770             return True;
 771          end if;
 772
 773          Mark (S.File, Index => S.Index);
 774
 775          return False;
 776       end Was_Processed;
 777
 778       -------------------
 779       -- Debug_Display --
 780       -------------------
 781
 782       procedure Debug_Display (S : Source_Info) is
 783       begin
 784          Write_Name (S.File);
 785
 786          if S.Index /= 0 then
 787             Write_Str (", ");
 788             Write_Int (S.Index);
 789          end if;
 790       end Debug_Display;
 791
 792       ----------
 793       -- Hash --
 794       ----------
 795
 796       function Hash (Key : Mark_Key) return Mark_Num is
 797       begin
 798          return Union_Id (Key.File) mod Max_Mask_Num;
 799       end Hash;
 800
 801       ---------------
 802       -- Is_Marked --
 803       ---------------
 804
 805       function Is_Marked
 806         (Source_File : File_Name_Type;
 807          Index       : Int := 0) return Boolean
 808       is
 809       begin
 810          return Marks.Get (K => (File => Source_File, Index => Index));
 811       end Is_Marked;
 812
 813       ----------
 814       -- Mark --
 815       ----------
 816
 817       procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
 818       begin
 819          Marks.Set (K => (File => Source_File, Index => Index), E => True);
 820       end Mark;
 821
 822       -------------
 823       -- Extract --
 824       -------------
 825
 826       procedure Extract
 827         (Found  : out Boolean;
 828          Source : out Source_Info)
 829       is
 830       begin
 831          Found := False;
 832
 833          if Q_First <= Q.Last then
 834             Source := Q.Table (Q_First).Info;
 835             Q.Table (Q_First).Processed := True;
 836             Q_First := Q_First + 1;
 837             Found := True;
 838          end if;
 839
 840          if Found then
 841             Q_Processed := Q_Processed + 1;
 842          end if;
 843
 844          if Found and then Debug.Debug_Flag_Q then
 845             Write_Str ("   Q := Q - [ ");
 846             Debug_Display (Source);
 847             Write_Str (" ]");
 848             Write_Eol;
 849
 850             Write_Str ("   Q_First =");
 851             Write_Int (Int (Q_First));
 852             Write_Eol;
 853
 854             Write_Str ("   Q.Last =");
 855             Write_Int (Int (Q.Last));
 856             Write_Eol;
 857          end if;
 858       end Extract;
 859
 860       ---------------
 861       -- Processed --
 862       ---------------
 863
 864       function Processed return Natural is
 865       begin
 866          return Q_Processed;
 867       end Processed;
 868
 869       ----------------
 870       -- Initialize --
 871       ----------------
 872
 873       procedure Initialize (Force : Boolean := False) is
 874       begin
 875          if Force or else not Q_Initialized then
 876             Q_Initialized := True;
 877             Q.Init;
 878             Q_Processed := 0;
 879             Q_First     := 1;
 880          end if;
 881       end Initialize;
 882
 883       ------------
 884       -- Insert --
 885       ------------
 886
 887       function Insert (Source  : Source_Info) return Boolean is
 888       begin
 889          --  Only insert in the Q if it is not already done, to avoid
 890          --  simultaneous compilations if -jnnn is used.
 891
 892          if Was_Processed (Source) then
 893             return False;
 894          end if;
 895
 896          Q.Append (New_Val => (Info => Source, Processed => False));
 897
 898          if Debug.Debug_Flag_Q then
 899             Write_Str ("   Q := Q + [ ");
 900             Debug_Display (Source);
 901             Write_Str (" ] ");
 902             Write_Eol;
 903
 904             Write_Str ("   Q_First =");
 905             Write_Int (Int (Q_First));
 906             Write_Eol;
 907
 908             Write_Str ("   Q.Last =");
 909             Write_Int (Int (Q.Last));
 910             Write_Eol;
 911          end if;
 912
 913          return True;
 914       end Insert;
 915
 916       procedure Insert (Source : Source_Info) is
 917          Discard : Boolean;
 918       begin
 919          Discard := Insert (Source);
 920       end Insert;
 921
 922       --------------
 923       -- Is_Empty --
 924       --------------
 925
 926       function Is_Empty return Boolean is
 927       begin
 928          return Q_Processed >= Q.Last;
 929       end Is_Empty;
 930
 931       ----------
 932       -- Size --
 933       ----------
 934
 935       function Size return Natural is
 936       begin
 937          return Q.Last;
 938       end Size;
 939
 940       -------------
 941       -- Element --
 942       -------------
 943
 944       function Element (Rank : Positive) return File_Name_Type is
 945       begin
 946          if Rank <= Q.Last then
 947             return Q.Table (Rank).Info.File;
 948          else
 949             return No_File;
 950          end if;
 951       end Element;
 952
 953       ------------------
 954       -- Remove_Marks --
 955       ------------------
 956
 957       procedure Remove_Marks is
 958       begin
 959          Marks.Reset;
 960       end Remove_Marks;
 961
 962    end Queue;
 963
 964 end Make_Util;