gcc/ada/clean.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                C L E A N                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2003-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.  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 ALI;      use ALI;
  27 with Csets;
  28 with Makeutl;  use Makeutl;
  29 with MLib.Tgt; use MLib.Tgt;
  30 with Namet;    use Namet;
  31 with Opt;      use Opt;
  32 with Osint;    use Osint;
  33 with Osint.M;  use Osint.M;
  34 with Prj;      use Prj;
  35 with Prj.Env;
  36 with Prj.Ext;
  37 with Prj.Pars;
  38 with Prj.Util; use Prj.Util;
  39 with Snames;
  40 with Switch;   use Switch;
  41 with Table;
  42 with Targparm; use Targparm;
  43 with Types;    use Types;
  44
  45 with Ada.Command_Line;          use Ada.Command_Line;
  46
  47 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  48 with GNAT.IO;                   use GNAT.IO;
  49 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  50
  51 package body Clean is
  52
  53    Initialized : Boolean := False;
  54    --  Set to True by the first call to Initialize.
  55    --  To avoid reinitialization of some packages.
  56
  57    --  Suffixes of various files
  58
  59    Assembly_Suffix : constant String := ".s";
  60    ALI_Suffix      : constant String := ".ali";
  61    Tree_Suffix     : constant String := ".adt";
  62    Object_Suffix   : constant String := Get_Target_Object_Suffix.all;
  63    Debug_Suffix    : String          := ".dg";
  64    --  Changed to "_dg" for VMS in the body of the package
  65
  66    Repinfo_Suffix  : String := ".rep";
  67    --  Changed to "_rep" for VMS in the body of the package
  68
  69    B_Start : String_Ptr := new String'("b~");
  70    --  Prefix of binder generated file, and number of actual characters used.
  71    --  Changed to "b__" for VMS in the body of the package.
  72
  73    Object_Directory_Path : String_Access := null;
  74    --  The path name of the object directory, set with switch -D
  75
  76    Force_Deletions : Boolean := False;
  77    --  Set to True by switch -f. When True, attempts to delete non writable
  78    --  files will be done.
  79
  80    Do_Nothing : Boolean := False;
  81    --  Set to True when switch -n is specified. When True, no file is deleted.
  82    --  gnatclean only lists the files that would have been deleted if the
  83    --  switch -n had not been specified.
  84
  85    File_Deleted : Boolean := False;
  86    --  Set to True if at least one file has been deleted
  87
  88    Copyright_Displayed : Boolean := False;
  89    Usage_Displayed     : Boolean := False;
  90
  91    Project_File_Name : String_Access := null;
  92
  93    Project_Tree : constant Prj.Project_Tree_Ref := new Prj.Project_Tree_Data;
  94
  95    Main_Project : Prj.Project_Id := Prj.No_Project;
  96
  97    All_Projects : Boolean := False;
  98
  99    --  Packages of project files where unknown attributes are errors
 100
 101    Naming_String   : aliased String := "naming";
 102    Builder_String  : aliased String := "builder";
 103    Compiler_String : aliased String := "compiler";
 104    Binder_String   : aliased String := "binder";
 105    Linker_String   : aliased String := "linker";
 106
 107    Gnatmake_Packages : aliased String_List :=
 108      (Naming_String   'Access,
 109       Builder_String  'Access,
 110       Compiler_String 'Access,
 111       Binder_String   'Access,
 112       Linker_String   'Access);
 113
 114    Packages_To_Check_By_Gnatmake : constant String_List_Access :=
 115      Gnatmake_Packages'Access;
 116
 117    package Processed_Projects is new Table.Table
 118      (Table_Component_Type => Project_Id,
 119       Table_Index_Type     => Natural,
 120       Table_Low_Bound      => 0,
 121       Table_Initial        => 10,
 122       Table_Increment      => 100,
 123       Table_Name           => "Clean.Processed_Projects");
 124    --  Table to keep track of what project files have been processed, when
 125    --  switch -r is specified.
 126
 127    package Sources is new Table.Table
 128      (Table_Component_Type => File_Name_Type,
 129       Table_Index_Type     => Natural,
 130       Table_Low_Bound      => 0,
 131       Table_Initial        => 10,
 132       Table_Increment      => 100,
 133       Table_Name           => "Clean.Processed_Projects");
 134    --  Table to store all the source files of a library unit: spec, body and
 135    --  subunits, to detect .dg files and delete them.
 136
 137    ----------------------------
 138    -- Queue (Q) manipulation --
 139    ----------------------------
 140
 141    procedure Init_Q;
 142    --  Must be called to initialize the Q
 143
 144    procedure Insert_Q (Lib_File  : File_Name_Type);
 145    --  If Lib_File is not marked, inserts it at the end of Q and mark it
 146
 147    function Empty_Q return Boolean;
 148    --  Returns True if Q is empty
 149
 150    procedure Extract_From_Q (Lib_File : out File_Name_Type);
 151    --  Extracts the first element from the Q
 152
 153    Q_Front : Natural;
 154    --  Points to the first valid element in the Q
 155
 156    package Q is new Table.Table (
 157      Table_Component_Type => File_Name_Type,
 158      Table_Index_Type     => Natural,
 159      Table_Low_Bound      => 0,
 160      Table_Initial        => 4000,
 161      Table_Increment      => 100,
 162      Table_Name           => "Clean.Q");
 163    --  This is the actual queue
 164
 165    -----------------------------
 166    -- Other local subprograms --
 167    -----------------------------
 168
 169    procedure Add_Source_Dir (N : String);
 170    --  Call Add_Src_Search_Dir and output one line when in verbose mode
 171
 172    procedure Add_Source_Directories is
 173      new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir);
 174
 175    procedure Add_Object_Dir (N : String);
 176    --  Call Add_Lib_Search_Dir and output one line when in verbose mode
 177
 178    procedure Add_Object_Directories is
 179      new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
 180
 181    function ALI_File_Name (Source : File_Name_Type) return String;
 182    --  Returns the name of the ALI file corresponding to Source
 183
 184    function Assembly_File_Name (Source : File_Name_Type) return String;
 185    --  Returns the assembly file name corresponding to Source
 186
 187    procedure Clean_Archive (Project : Project_Id; Global : Boolean);
 188    --  Delete a global archive or library project archive and the dependency
 189    --  file, if they exist.
 190
 191    procedure Clean_Executables;
 192    --  Do the cleaning work when no project file is specified
 193
 194    procedure Clean_Interface_Copy_Directory (Project : Project_Id);
 195    --  Delete files in an interface copy directory: any file that is a copy of
 196    --  a source of the project.
 197
 198    procedure Clean_Library_Directory (Project : Project_Id);
 199    --  Delete the library file in a library directory and any ALI file of a
 200    --  source of the project in a library ALI directory.
 201
 202    procedure Clean_Project (Project : Project_Id);
 203    --  Do the cleaning work when a project file is specified. This procedure
 204    --  calls itself recursively when there are several project files in the
 205    --  tree rooted at the main project file and switch -r has been specified.
 206
 207    function Debug_File_Name (Source : File_Name_Type) return String;
 208    --  Name of the expanded source file corresponding to Source
 209
 210    procedure Delete (In_Directory : String; File : String);
 211    --  Delete one file, or list the file name if switch -n is specified
 212
 213    procedure Delete_Binder_Generated_Files
 214      (Dir    : String;
 215       Source : File_Name_Type);
 216    --  Delete the binder generated file in directory Dir for Source, if they
 217    --  exist: for Unix these are b~<source>.ads, b~<source>.adb,
 218    --  b~<source>.ali and b~<source>.o.
 219
 220    procedure Display_Copyright;
 221    --  Display the Copyright notice. If called several times, display the
 222    --  Copyright notice only the first time.
 223
 224    procedure Initialize;
 225    --  Call the necessary package initializations
 226
 227    function Object_File_Name (Source : File_Name_Type) return String;
 228    --  Returns the object file name corresponding to Source
 229
 230    procedure Parse_Cmd_Line;
 231    --  Parse the command line
 232
 233    function Repinfo_File_Name (Source : File_Name_Type) return String;
 234    --  Returns the repinfo file name corresponding to Source
 235
 236    function Tree_File_Name (Source : File_Name_Type) return String;
 237    --  Returns the tree file name corresponding to Source
 238
 239    function In_Extension_Chain
 240      (Of_Project : Project_Id;
 241       Prj        : Project_Id) return Boolean;
 242    --  Returns True iff Prj is an extension of Of_Project or if Of_Project is
 243    --  an extension of Prj.
 244
 245    procedure Usage;
 246    --  Display the usage. If called several times, the usage is displayed only
 247    --  the first time.
 248
 249    --------------------
 250    -- Add_Object_Dir --
 251    --------------------
 252
 253    procedure Add_Object_Dir (N : String) is
 254    begin
 255       Add_Lib_Search_Dir (N);
 256
 257       if Opt.Verbose_Mode then
 258          Put ("Adding object directory """);
 259          Put (N);
 260          Put (""".");
 261          New_Line;
 262       end if;
 263    end Add_Object_Dir;
 264
 265    --------------------
 266    -- Add_Source_Dir --
 267    --------------------
 268
 269    procedure Add_Source_Dir (N : String) is
 270    begin
 271       Add_Src_Search_Dir (N);
 272
 273       if Opt.Verbose_Mode then
 274          Put ("Adding source directory """);
 275          Put (N);
 276          Put (""".");
 277          New_Line;
 278       end if;
 279    end Add_Source_Dir;
 280
 281    -------------------
 282    -- ALI_File_Name --
 283    -------------------
 284
 285    function ALI_File_Name (Source : File_Name_Type) return String is
 286       Src : constant String := Get_Name_String (Source);
 287
 288    begin
 289       --  If the source name has an extension, then replace it with
 290       --  the ALI suffix.
 291
 292       for Index in reverse Src'First + 1 .. Src'Last loop
 293          if Src (Index) = '.' then
 294             return Src (Src'First .. Index - 1) & ALI_Suffix;
 295          end if;
 296       end loop;
 297
 298       --  If there is no dot, or if it is the first character, just add the
 299       --  ALI suffix.
 300
 301       return Src & ALI_Suffix;
 302    end ALI_File_Name;
 303
 304    ------------------------
 305    -- Assembly_File_Name --
 306    ------------------------
 307
 308    function Assembly_File_Name (Source : File_Name_Type) return String is
 309       Src : constant String := Get_Name_String (Source);
 310
 311    begin
 312       --  If the source name has an extension, then replace it with
 313       --  the assembly suffix.
 314
 315       for Index in reverse Src'First + 1 .. Src'Last loop
 316          if Src (Index) = '.' then
 317             return Src (Src'First .. Index - 1) & Assembly_Suffix;
 318          end if;
 319       end loop;
 320
 321       --  If there is no dot, or if it is the first character, just add the
 322       --  assembly suffix.
 323
 324       return Src & Assembly_Suffix;
 325    end Assembly_File_Name;
 326
 327    -------------------
 328    -- Clean_Archive --
 329    -------------------
 330
 331    procedure Clean_Archive (Project : Project_Id; Global : Boolean) is
 332       Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
 333
 334       Lib_Prefix : String_Access;
 335       Archive_Name : String_Access;
 336       --  The name of the archive file for this project
 337
 338       Archive_Dep_Name : String_Access;
 339       --  The name of the archive dependency file for this project
 340
 341       Obj_Dir : constant String :=
 342                   Get_Name_String (Project.Object_Directory.Display_Name);
 343
 344    begin
 345       Change_Dir (Obj_Dir);
 346
 347       --  First, get the lib prefix, the archive file name and the archive
 348       --  dependency file name.
 349
 350       if Global then
 351          Lib_Prefix :=
 352            new String'("lib" & Get_Name_String (Project.Display_Name));
 353       else
 354          Lib_Prefix :=
 355            new String'("lib" & Get_Name_String (Project.Library_Name));
 356       end if;
 357
 358       Archive_Name := new String'(Lib_Prefix.all & '.' & Archive_Ext);
 359       Archive_Dep_Name := new String'(Lib_Prefix.all & ".deps");
 360
 361       --  Delete the archive file and the archive dependency file, if they
 362       --  exist.
 363
 364       if Is_Regular_File (Archive_Name.all) then
 365          Delete (Obj_Dir, Archive_Name.all);
 366       end if;
 367
 368       if Is_Regular_File (Archive_Dep_Name.all) then
 369          Delete (Obj_Dir, Archive_Dep_Name.all);
 370       end if;
 371
 372       Change_Dir (Current_Dir);
 373    end Clean_Archive;
 374
 375    -----------------------
 376    -- Clean_Executables --
 377    -----------------------
 378
 379    procedure Clean_Executables is
 380       Main_Source_File : File_Name_Type;
 381       --  Current main source
 382
 383       Main_Lib_File : File_Name_Type;
 384       --  ALI file of the current main
 385
 386       Lib_File : File_Name_Type;
 387       --  Current ALI file
 388
 389       Full_Lib_File : File_Name_Type;
 390       --  Full name of the current ALI file
 391
 392       Text    : Text_Buffer_Ptr;
 393       The_ALI : ALI_Id;
 394
 395    begin
 396       Init_Q;
 397
 398       --  It does not really matter if there is or not an object file
 399       --  corresponding to an ALI file: if there is one, it will be deleted.
 400
 401       Opt.Check_Object_Consistency := False;
 402
 403       --  Proceed each executable one by one. Each source is marked as it is
 404       --  processed, so common sources between executables will not be
 405       --  processed several times.
 406
 407       for N_File in 1 .. Osint.Number_Of_Files loop
 408          Main_Source_File := Next_Main_Source;
 409          Main_Lib_File := Osint.Lib_File_Name
 410                              (Main_Source_File, Current_File_Index);
 411          Insert_Q (Main_Lib_File);
 412
 413          while not Empty_Q loop
 414             Sources.Set_Last (0);
 415             Extract_From_Q (Lib_File);
 416             Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
 417
 418             --  If we have existing ALI file that is not read-only, process it
 419
 420             if Full_Lib_File /= No_File
 421               and then not Is_Readonly_Library (Full_Lib_File)
 422             then
 423                Text := Read_Library_Info (Lib_File);
 424
 425                if Text /= null then
 426                   The_ALI :=
 427                     Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
 428                   Free (Text);
 429
 430                   --  If no error was produced while loading this ALI file,
 431                   --  insert into the queue all the unmarked withed sources.
 432
 433                   if The_ALI /= No_ALI_Id then
 434                      for J in ALIs.Table (The_ALI).First_Unit ..
 435                        ALIs.Table (The_ALI).Last_Unit
 436                      loop
 437                         Sources.Increment_Last;
 438                         Sources.Table (Sources.Last) :=
 439                           ALI.Units.Table (J).Sfile;
 440
 441                         for K in ALI.Units.Table (J).First_With ..
 442                           ALI.Units.Table (J).Last_With
 443                         loop
 444                            Insert_Q (Withs.Table (K).Afile);
 445                         end loop;
 446                      end loop;
 447
 448                      --  Look for subunits and put them in the Sources table
 449
 450                      for J in ALIs.Table (The_ALI).First_Sdep ..
 451                        ALIs.Table (The_ALI).Last_Sdep
 452                      loop
 453                         if Sdep.Table (J).Subunit_Name /= No_Name then
 454                            Sources.Increment_Last;
 455                            Sources.Table (Sources.Last) :=
 456                              Sdep.Table (J).Sfile;
 457                         end if;
 458                      end loop;
 459                   end if;
 460                end if;
 461
 462                --  Now delete all existing files corresponding to this ALI file
 463
 464                declare
 465                   Obj_Dir : constant String :=
 466                               Dir_Name (Get_Name_String (Full_Lib_File));
 467                   Obj     : constant String := Object_File_Name (Lib_File);
 468                   Adt     : constant String := Tree_File_Name   (Lib_File);
 469                   Asm     : constant String := Assembly_File_Name (Lib_File);
 470
 471                begin
 472                   Delete (Obj_Dir, Get_Name_String (Lib_File));
 473
 474                   if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then
 475                      Delete (Obj_Dir, Obj);
 476                   end if;
 477
 478                   if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then
 479                      Delete (Obj_Dir, Adt);
 480                   end if;
 481
 482                   if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then
 483                      Delete (Obj_Dir, Asm);
 484                   end if;
 485
 486                   --  Delete expanded source files (.dg) and/or repinfo files
 487                   --  (.rep) if any
 488
 489                   for J in 1 .. Sources.Last loop
 490                      declare
 491                         Deb : constant String :=
 492                                 Debug_File_Name (Sources.Table (J));
 493                         Rep : constant String :=
 494                                 Repinfo_File_Name (Sources.Table (J));
 495
 496                      begin
 497                         if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
 498                            Delete (Obj_Dir, Deb);
 499                         end if;
 500
 501                         if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then
 502                            Delete (Obj_Dir, Rep);
 503                         end if;
 504                      end;
 505                   end loop;
 506                end;
 507             end if;
 508          end loop;
 509
 510          --  Delete the executable, if it exists, and the binder generated
 511          --  files, if any.
 512
 513          if not Compile_Only then
 514             declare
 515                Source     : constant File_Name_Type :=
 516                               Strip_Suffix (Main_Lib_File);
 517                Executable : constant String :=
 518                               Get_Name_String (Executable_Name (Source));
 519             begin
 520                if Is_Regular_File (Executable) then
 521                   Delete ("", Executable);
 522                end if;
 523
 524                Delete_Binder_Generated_Files (Get_Current_Dir, Source);
 525             end;
 526          end if;
 527       end loop;
 528    end Clean_Executables;
 529
 530    ------------------------------------
 531    -- Clean_Interface_Copy_Directory --
 532    ------------------------------------
 533
 534    procedure Clean_Interface_Copy_Directory (Project : Project_Id) is
 535       Current : constant String := Get_Current_Dir;
 536
 537       Direc : Dir_Type;
 538
 539       Name : String (1 .. 200);
 540       Last : Natural;
 541
 542       Delete_File : Boolean;
 543       Unit        : Unit_Index;
 544
 545    begin
 546       if Project.Library
 547         and then Project.Library_Src_Dir /= No_Path_Information
 548       then
 549          declare
 550             Directory : constant String :=
 551                         Get_Name_String (Project.Library_Src_Dir.Display_Name);
 552
 553          begin
 554             Change_Dir (Directory);
 555             Open (Direc, ".");
 556
 557             --  For each regular file in the directory, if switch -n has not
 558             --  been specified, make it writable and delete the file if it is
 559             --  a copy of a source of the project.
 560
 561             loop
 562                Read (Direc, Name, Last);
 563                exit when Last = 0;
 564
 565                declare
 566                   Filename : constant String := Name (1 .. Last);
 567
 568                begin
 569                   if Is_Regular_File (Filename) then
 570                      Canonical_Case_File_Name (Name (1 .. Last));
 571                      Delete_File := False;
 572
 573                      Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
 574
 575                      --  Compare with source file names of the project
 576
 577                      while Unit /= No_Unit_Index loop
 578                         if Unit.File_Names (Impl) /= null
 579                           and then Ultimate_Extending_Project_Of
 580                                      (Unit.File_Names (Impl).Project) = Project
 581                           and then
 582                             Get_Name_String (Unit.File_Names (Impl).File) =
 583                                                               Name (1 .. Last)
 584                         then
 585                            Delete_File := True;
 586                            exit;
 587                         end if;
 588
 589                         if Unit.File_Names (Spec) /= null
 590                           and then Ultimate_Extending_Project_Of
 591                                      (Unit.File_Names (Spec).Project) = Project
 592                           and then
 593                             Get_Name_String
 594                               (Unit.File_Names (Spec).File) = Name (1 .. Last)
 595                         then
 596                            Delete_File := True;
 597                            exit;
 598                         end if;
 599
 600                         Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
 601                      end loop;
 602
 603                      if Delete_File then
 604                         if not Do_Nothing then
 605                            Set_Writable (Filename);
 606                         end if;
 607
 608                         Delete (Directory, Filename);
 609                      end if;
 610                   end if;
 611                end;
 612             end loop;
 613
 614             Close (Direc);
 615
 616             --  Restore the initial working directory
 617
 618             Change_Dir (Current);
 619          end;
 620       end if;
 621    end Clean_Interface_Copy_Directory;
 622
 623    -----------------------------
 624    -- Clean_Library_Directory --
 625    -----------------------------
 626
 627    Empty_String : aliased String := "";
 628
 629    procedure Clean_Library_Directory (Project : Project_Id) is
 630       Current : constant String := Get_Current_Dir;
 631
 632       Lib_Filename : constant String := Get_Name_String (Project.Library_Name);
 633       DLL_Name     : String :=
 634                        DLL_Prefix & Lib_Filename & "." & DLL_Ext;
 635       Archive_Name : String :=
 636                        "lib" & Lib_Filename & "." & Archive_Ext;
 637       Direc        : Dir_Type;
 638
 639       Name : String (1 .. 200);
 640       Last : Natural;
 641
 642       Delete_File : Boolean;
 643
 644       Minor : String_Access := Empty_String'Access;
 645       Major : String_Access := Empty_String'Access;
 646
 647    begin
 648       if Project.Library then
 649          if Project.Library_Kind /= Static
 650            and then MLib.Tgt.Library_Major_Minor_Id_Supported
 651            and then Project.Lib_Internal_Name /= No_Name
 652          then
 653             Minor := new String'(Get_Name_String (Project.Lib_Internal_Name));
 654             Major := new String'(MLib.Major_Id_Name (DLL_Name, Minor.all));
 655          end if;
 656
 657          declare
 658             Lib_Directory     : constant String :=
 659                                   Get_Name_String
 660                                     (Project.Library_Dir.Display_Name);
 661             Lib_ALI_Directory : constant String :=
 662                                   Get_Name_String
 663                                     (Project.Library_ALI_Dir.Display_Name);
 664
 665          begin
 666             Canonical_Case_File_Name (Archive_Name);
 667             Canonical_Case_File_Name (DLL_Name);
 668
 669             Change_Dir (Lib_Directory);
 670             Open (Direc, ".");
 671
 672             --  For each regular file in the directory, if switch -n has not
 673             --  been specified, make it writable and delete the file if it is
 674             --  the library file.
 675
 676             loop
 677                Read (Direc, Name, Last);
 678                exit when Last = 0;
 679
 680                declare
 681                   Filename : constant String := Name (1 .. Last);
 682
 683                begin
 684                   if Is_Regular_File (Filename)
 685                     or else Is_Symbolic_Link (Filename)
 686                   then
 687                      Canonical_Case_File_Name (Name (1 .. Last));
 688                      Delete_File := False;
 689
 690                      if (Project.Library_Kind = Static
 691                           and then Name (1 .. Last) =  Archive_Name)
 692                        or else
 693                          ((Project.Library_Kind = Dynamic
 694                              or else
 695                            Project.Library_Kind = Relocatable)
 696                           and then
 697                             (Name (1 .. Last) = DLL_Name
 698                                or else
 699                              Name (1 .. Last) = Minor.all
 700                                or else
 701                              Name (1 .. Last) = Major.all))
 702                      then
 703                         if not Do_Nothing then
 704                            Set_Writable (Filename);
 705                         end if;
 706
 707                         Delete (Lib_Directory, Filename);
 708                      end if;
 709                   end if;
 710                end;
 711             end loop;
 712
 713             Close (Direc);
 714
 715             Change_Dir (Lib_ALI_Directory);
 716             Open (Direc, ".");
 717
 718             --  For each regular file in the directory, if switch -n has not
 719             --  been specified, make it writable and delete the file if it is
 720             --  any ALI file of a source of the project.
 721
 722             loop
 723                Read (Direc, Name, Last);
 724                exit when Last = 0;
 725
 726                declare
 727                   Filename : constant String := Name (1 .. Last);
 728                begin
 729                   if Is_Regular_File (Filename) then
 730                      Canonical_Case_File_Name (Name (1 .. Last));
 731                      Delete_File := False;
 732
 733                      if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
 734                         declare
 735                            Unit : Unit_Index;
 736                         begin
 737                            --  Compare with ALI file names of the project
 738
 739                            Unit := Units_Htable.Get_First
 740                              (Project_Tree.Units_HT);
 741                            while Unit /= No_Unit_Index loop
 742                               if Unit.File_Names (Impl) /= null
 743                                 and then Unit.File_Names (Impl).Project /=
 744                                                                    No_Project
 745                               then
 746                                  if Ultimate_Extending_Project_Of
 747                                       (Unit.File_Names (Impl).Project) =
 748                                                                    Project
 749                                  then
 750                                     Get_Name_String
 751                                       (Unit.File_Names (Impl).File);
 752                                     Name_Len := Name_Len -
 753                                       File_Extension
 754                                         (Name (1 .. Name_Len))'Length;
 755                                     if Name_Buffer (1 .. Name_Len) =
 756                                          Name (1 .. Last - 4)
 757                                     then
 758                                        Delete_File := True;
 759                                        exit;
 760                                     end if;
 761                                  end if;
 762
 763                               elsif Unit.File_Names (Spec) /= null
 764                                 and then Ultimate_Extending_Project_Of
 765                                            (Unit.File_Names (Spec).Project) =
 766                                                                     Project
 767                               then
 768                                  Get_Name_String
 769                                    (Unit.File_Names (Spec).File);
 770                                  Name_Len :=
 771                                    Name_Len -
 772                                      File_Extension
 773                                        (Name (1 .. Name_Len))'Length;
 774
 775                                  if Name_Buffer (1 .. Name_Len) =
 776                                       Name (1 .. Last - 4)
 777                                  then
 778                                     Delete_File := True;
 779                                     exit;
 780                                  end if;
 781                               end if;
 782
 783                               Unit :=
 784                                 Units_Htable.Get_Next (Project_Tree.Units_HT);
 785                            end loop;
 786                         end;
 787                      end if;
 788
 789                      if Delete_File then
 790                         if not Do_Nothing then
 791                            Set_Writable (Filename);
 792                         end if;
 793
 794                         Delete (Lib_ALI_Directory, Filename);
 795                      end if;
 796                   end if;
 797                end;
 798             end loop;
 799
 800             Close (Direc);
 801
 802             --  Restore the initial working directory
 803
 804             Change_Dir (Current);
 805          end;
 806       end if;
 807    end Clean_Library_Directory;
 808
 809    -------------------
 810    -- Clean_Project --
 811    -------------------
 812
 813    procedure Clean_Project (Project : Project_Id) is
 814       Main_Source_File : File_Name_Type;
 815       --  Name of executable on the command line without directory info
 816
 817       Executable : File_Name_Type;
 818       --  Name of the executable file
 819
 820       Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
 821       Unit        : Unit_Index;
 822       File_Name1  : File_Name_Type;
 823       Index1      : Int;
 824       File_Name2  : File_Name_Type;
 825       Index2      : Int;
 826       Lib_File    : File_Name_Type;
 827
 828       Global_Archive : Boolean := False;
 829
 830    begin
 831       --  Check that we don't specify executable on the command line for
 832       --  a main library project.
 833
 834       if Project = Main_Project
 835         and then Osint.Number_Of_Files /= 0
 836         and then Project.Library
 837       then
 838          Osint.Fail
 839            ("Cannot specify executable(s) for a Library Project File");
 840       end if;
 841
 842       --  Nothing to clean in an externally built project
 843
 844       if Project.Externally_Built then
 845          if Verbose_Mode then
 846             Put ("Nothing to do to clean externally built project """);
 847             Put (Get_Name_String (Project.Name));
 848             Put_Line ("""");
 849          end if;
 850
 851       else
 852          if Verbose_Mode then
 853             Put ("Cleaning project """);
 854             Put (Get_Name_String (Project.Name));
 855             Put_Line ("""");
 856          end if;
 857
 858          --  Add project to the list of processed projects
 859
 860          Processed_Projects.Increment_Last;
 861          Processed_Projects.Table (Processed_Projects.Last) := Project;
 862
 863          if Project.Object_Directory /= No_Path_Information then
 864             declare
 865                Obj_Dir : constant String :=
 866                            Get_Name_String
 867                              (Project.Object_Directory.Display_Name);
 868
 869             begin
 870                Change_Dir (Obj_Dir);
 871
 872                --  First, deal with Ada
 873
 874                --  Look through the units to find those that are either
 875                --  immediate sources or inherited sources of the project.
 876                --  Extending projects may have no language specified, if
 877                --  Source_Dirs or Source_Files is specified as an empty list,
 878                --  so always look for Ada units in extending projects.
 879
 880                if Has_Ada_Sources (Project)
 881                  or else Project.Extends /= No_Project
 882                then
 883                   Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
 884                   while Unit /= No_Unit_Index loop
 885                      File_Name1 := No_File;
 886                      File_Name2 := No_File;
 887
 888                      --  If either the spec or the body is a source of the
 889                      --  project, check for the corresponding ALI file in the
 890                      --  object directory.
 891
 892                      if (Unit.File_Names (Impl) /= null
 893                          and then
 894                            In_Extension_Chain
 895                              (Unit.File_Names (Impl).Project, Project))
 896                        or else
 897                          (Unit.File_Names (Spec) /= null
 898                           and then In_Extension_Chain
 899                             (Unit.File_Names (Spec).Project, Project))
 900                      then
 901                         if Unit.File_Names (Impl) /= null then
 902                            File_Name1 := Unit.File_Names (Impl).File;
 903                            Index1     := Unit.File_Names (Impl).Index;
 904                         else
 905                            File_Name1 := No_File;
 906                            Index1     := 0;
 907                         end if;
 908
 909                         if Unit.File_Names (Spec) /= null then
 910                            File_Name2 := Unit.File_Names (Spec).File;
 911                            Index2     := Unit.File_Names (Spec).Index;
 912                         else
 913                            File_Name2 := No_File;
 914                            Index2     := 0;
 915                         end if;
 916
 917                         --  If there is no body file name, then there may be
 918                         --  only a spec.
 919
 920                         if File_Name1 = No_File then
 921                            File_Name1 := File_Name2;
 922                            Index1     := Index2;
 923                            File_Name2 := No_File;
 924                            Index2     := 0;
 925                         end if;
 926                      end if;
 927
 928                      --  If there is either a spec or a body, look for files
 929                      --  in the object directory.
 930
 931                      if File_Name1 /= No_File then
 932                         Lib_File := Osint.Lib_File_Name (File_Name1, Index1);
 933
 934                         declare
 935                            Asm : constant String :=
 936                                    Assembly_File_Name (Lib_File);
 937                            ALI : constant String :=
 938                                    ALI_File_Name      (Lib_File);
 939                            Obj : constant String :=
 940                                    Object_File_Name   (Lib_File);
 941                            Adt : constant String :=
 942                                    Tree_File_Name     (Lib_File);
 943                            Deb : constant String :=
 944                                    Debug_File_Name    (File_Name1);
 945                            Rep : constant String :=
 946                                    Repinfo_File_Name  (File_Name1);
 947                            Del : Boolean := True;
 948
 949                         begin
 950                            --  If the ALI file exists and is read-only, no file
 951                            --  is deleted.
 952
 953                            if Is_Regular_File (ALI) then
 954                               if Is_Writable_File (ALI) then
 955                                  Delete (Obj_Dir, ALI);
 956
 957                               else
 958                                  Del := False;
 959
 960                                  if Verbose_Mode then
 961                                     Put ('"');
 962                                     Put (Obj_Dir);
 963
 964                                     if Obj_Dir (Obj_Dir'Last) /=
 965                                       Dir_Separator
 966                                     then
 967                                        Put (Dir_Separator);
 968                                     end if;
 969
 970                                     Put (ALI);
 971                                     Put_Line (""" is read-only");
 972                                  end if;
 973                               end if;
 974                            end if;
 975
 976                            if Del then
 977
 978                               --  Object file
 979
 980                               if Is_Regular_File (Obj) then
 981                                  Delete (Obj_Dir, Obj);
 982                               end if;
 983
 984                               --  Assembly file
 985
 986                               if Is_Regular_File (Asm) then
 987                                  Delete (Obj_Dir, Asm);
 988                               end if;
 989
 990                               --  Tree file
 991
 992                               if Is_Regular_File (Adt) then
 993                                  Delete (Obj_Dir, Adt);
 994                               end if;
 995
 996                               --  First expanded source file
 997
 998                               if Is_Regular_File (Deb) then
 999                                  Delete (Obj_Dir, Deb);
1000                               end if;
1001
1002                               --  Repinfo file
1003
1004                               if Is_Regular_File (Rep) then
1005                                  Delete (Obj_Dir, Rep);
1006                               end if;
1007
1008                               --  Second expanded source file
1009
1010                               if File_Name2 /= No_File then
1011                                  declare
1012                                     Deb : constant String :=
1013                                             Debug_File_Name (File_Name2);
1014                                     Rep : constant String :=
1015                                             Repinfo_File_Name (File_Name2);
1016
1017                                  begin
1018                                     if Is_Regular_File (Deb) then
1019                                        Delete (Obj_Dir, Deb);
1020                                     end if;
1021
1022                                     if Is_Regular_File (Rep) then
1023                                        Delete (Obj_Dir, Rep);
1024                                     end if;
1025                                  end;
1026                               end if;
1027                            end if;
1028                         end;
1029                      end if;
1030
1031                      Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
1032                   end loop;
1033                end if;
1034
1035                --  Check if a global archive and it dependency file could have
1036                --  been created and, if they exist, delete them.
1037
1038                if Project = Main_Project and then not Project.Library then
1039                   Global_Archive := False;
1040
1041                   declare
1042                      Proj : Project_List;
1043
1044                   begin
1045                      Proj := Project_Tree.Projects;
1046                      while Proj /= null loop
1047
1048                         --  For gnatmake, when the project specifies more than
1049                         --  just Ada as a language (even if course we could not
1050                         --  find any source file for the other languages), we
1051                         --  will take all the object files found in the object
1052                         --  directories. Since we know the project supports at
1053                         --  least Ada, we just have to test whether it has at
1054                         --  least two languages, and we do not care about the
1055                         --  sources.
1056
1057                         if Proj.Project.Languages /= null
1058                           and then Proj.Project.Languages.Next /= null
1059                         then
1060                            Global_Archive := True;
1061                            exit;
1062                         end if;
1063
1064                         Proj := Proj.Next;
1065                      end loop;
1066                   end;
1067
1068                   if Global_Archive then
1069                      Clean_Archive (Project, Global => True);
1070                   end if;
1071                end if;
1072
1073             end;
1074          end if;
1075
1076          --  If this is a library project, clean the library directory, the
1077          --  interface copy dir and, for a Stand-Alone Library, the binder
1078          --  generated files of the library.
1079
1080          --  The directories are cleaned only if switch -c is not specified
1081
1082          if Project.Library then
1083             if not Compile_Only then
1084                Clean_Library_Directory (Project);
1085
1086                if Project.Library_Src_Dir /= No_Path_Information then
1087                   Clean_Interface_Copy_Directory (Project);
1088                end if;
1089             end if;
1090
1091             if Project.Standalone_Library and then
1092               Project.Object_Directory /= No_Path_Information
1093             then
1094                Delete_Binder_Generated_Files
1095                  (Get_Name_String (Project.Object_Directory.Display_Name),
1096                   File_Name_Type (Project.Library_Name));
1097             end if;
1098          end if;
1099
1100          if Verbose_Mode then
1101             New_Line;
1102          end if;
1103       end if;
1104
1105       --  If switch -r is specified, call Clean_Project recursively for the
1106       --  imported projects and the project being extended.
1107
1108       if All_Projects then
1109          declare
1110             Imported : Project_List;
1111             Process  : Boolean;
1112
1113          begin
1114             --  For each imported project, call Clean_Project if the project
1115             --  has not been processed already.
1116
1117             Imported := Project.Imported_Projects;
1118             while Imported /= null loop
1119                Process := True;
1120
1121                for
1122                  J in Processed_Projects.First .. Processed_Projects.Last
1123                loop
1124                   if Imported.Project = Processed_Projects.Table (J) then
1125                      Process := False;
1126                      exit;
1127                   end if;
1128                end loop;
1129
1130                if Process then
1131                   Clean_Project (Imported.Project);
1132                end if;
1133
1134                Imported := Imported.Next;
1135             end loop;
1136
1137             --  If this project extends another project, call Clean_Project for
1138             --  the project being extended. It is guaranteed that it has not
1139             --  called before, because no other project may import or extend
1140             --  this project.
1141
1142             if Project.Extends /= No_Project then
1143                Clean_Project (Project.Extends);
1144             end if;
1145          end;
1146       end if;
1147
1148          --  For the main project, delete the executables and the binder
1149          --  generated files.
1150
1151          --  The executables are deleted only if switch -c is not specified
1152
1153       if Project = Main_Project
1154         and then Project.Exec_Directory /= No_Path_Information
1155       then
1156          declare
1157             Exec_Dir : constant String :=
1158                          Get_Name_String (Project.Exec_Directory.Display_Name);
1159
1160          begin
1161             Change_Dir (Exec_Dir);
1162
1163             for N_File in 1 .. Osint.Number_Of_Files loop
1164                Main_Source_File := Next_Main_Source;
1165
1166                if not Compile_Only then
1167                   Executable :=
1168                     Executable_Of
1169                       (Main_Project,
1170                        Project_Tree,
1171                        Main_Source_File,
1172                        Current_File_Index);
1173
1174                   declare
1175                      Exec_File_Name : constant String :=
1176                                         Get_Name_String (Executable);
1177
1178                   begin
1179                      if Is_Absolute_Path (Name => Exec_File_Name) then
1180                         if Is_Regular_File (Exec_File_Name) then
1181                            Delete ("", Exec_File_Name);
1182                         end if;
1183
1184                      else
1185                         if Is_Regular_File (Exec_File_Name) then
1186                            Delete (Exec_Dir, Exec_File_Name);
1187                         end if;
1188                      end if;
1189                   end;
1190                end if;
1191
1192                if Project.Object_Directory /= No_Path_Information then
1193                   Delete_Binder_Generated_Files
1194                     (Get_Name_String (Project.Object_Directory.Display_Name),
1195                      Strip_Suffix (Main_Source_File));
1196                end if;
1197             end loop;
1198          end;
1199       end if;
1200
1201       --  Change back to previous directory
1202
1203       Change_Dir (Current_Dir);
1204    end Clean_Project;
1205
1206    ---------------------
1207    -- Debug_File_Name --
1208    ---------------------
1209
1210    function Debug_File_Name (Source : File_Name_Type) return String is
1211    begin
1212       return Get_Name_String (Source) & Debug_Suffix;
1213    end Debug_File_Name;
1214
1215    ------------
1216    -- Delete --
1217    ------------
1218
1219    procedure Delete (In_Directory : String; File : String) is
1220       Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
1221       Last      : Natural := 0;
1222       Success   : Boolean;
1223
1224    begin
1225       --  Indicate that at least one file is deleted or is to be deleted
1226
1227       File_Deleted := True;
1228
1229       --  Build the path name of the file to delete
1230
1231       Last := In_Directory'Length;
1232       Full_Name (1 .. Last) := In_Directory;
1233
1234       if Last > 0 and then Full_Name (Last) /= Directory_Separator then
1235          Last := Last + 1;
1236          Full_Name (Last) := Directory_Separator;
1237       end if;
1238
1239       Full_Name (Last + 1 .. Last + File'Length) := File;
1240       Last := Last + File'Length;
1241
1242       --  If switch -n was used, simply output the path name
1243
1244       if Do_Nothing then
1245          Put_Line (Full_Name (1 .. Last));
1246
1247       --  Otherwise, delete the file if it is writable
1248
1249       else
1250          if Force_Deletions
1251            or else Is_Writable_File (Full_Name (1 .. Last))
1252            or else Is_Symbolic_Link (Full_Name (1 .. Last))
1253          then
1254             Delete_File (Full_Name (1 .. Last), Success);
1255          else
1256             Success := False;
1257          end if;
1258
1259          if Verbose_Mode or else not Quiet_Output then
1260             if not Success then
1261                Put ("Warning: """);
1262                Put (Full_Name (1 .. Last));
1263                Put_Line (""" could not be deleted");
1264
1265             else
1266                Put ("""");
1267                Put (Full_Name (1 .. Last));
1268                Put_Line (""" has been deleted");
1269             end if;
1270          end if;
1271       end if;
1272    end Delete;
1273
1274    -----------------------------------
1275    -- Delete_Binder_Generated_Files --
1276    -----------------------------------
1277
1278    procedure Delete_Binder_Generated_Files
1279      (Dir    : String;
1280       Source : File_Name_Type)
1281    is
1282       Source_Name : constant String   := Get_Name_String (Source);
1283       Current     : constant String   := Get_Current_Dir;
1284       Last        : constant Positive := B_Start'Length + Source_Name'Length;
1285       File_Name   : String (1 .. Last + 4);
1286
1287    begin
1288       Change_Dir (Dir);
1289
1290       --  Build the file name (before the extension)
1291
1292       File_Name (1 .. B_Start'Length) := B_Start.all;
1293       File_Name (B_Start'Length + 1 .. Last) := Source_Name;
1294
1295       --  Spec
1296
1297       File_Name (Last + 1 .. Last + 4) := ".ads";
1298
1299       if Is_Regular_File (File_Name (1 .. Last + 4)) then
1300          Delete (Dir, File_Name (1 .. Last + 4));
1301       end if;
1302
1303       --  Body
1304
1305       File_Name (Last + 1 .. Last + 4) := ".adb";
1306
1307       if Is_Regular_File (File_Name (1 .. Last + 4)) then
1308          Delete (Dir, File_Name (1 .. Last + 4));
1309       end if;
1310
1311       --  ALI file
1312
1313       File_Name (Last + 1 .. Last + 4) := ".ali";
1314
1315       if Is_Regular_File (File_Name (1 .. Last + 4)) then
1316          Delete (Dir, File_Name (1 .. Last + 4));
1317       end if;
1318
1319       --  Object file
1320
1321       File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix;
1322
1323       if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then
1324          Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length));
1325       end if;
1326
1327       --  Change back to previous directory
1328
1329       Change_Dir (Current);
1330    end Delete_Binder_Generated_Files;
1331
1332    -----------------------
1333    -- Display_Copyright --
1334    -----------------------
1335
1336    procedure Display_Copyright is
1337    begin
1338       if not Copyright_Displayed then
1339          Copyright_Displayed := True;
1340          Display_Version ("GNATCLEAN", "2003");
1341       end if;
1342    end Display_Copyright;
1343
1344    -------------
1345    -- Empty_Q --
1346    -------------
1347
1348    function Empty_Q return Boolean is
1349    begin
1350       return Q_Front >= Q.Last;
1351    end Empty_Q;
1352
1353    --------------------
1354    -- Extract_From_Q --
1355    --------------------
1356
1357    procedure Extract_From_Q (Lib_File : out File_Name_Type) is
1358       Lib : constant File_Name_Type := Q.Table (Q_Front);
1359    begin
1360       Q_Front  := Q_Front + 1;
1361       Lib_File := Lib;
1362    end Extract_From_Q;
1363
1364    ---------------
1365    -- Gnatclean --
1366    ---------------
1367
1368    procedure Gnatclean is
1369    begin
1370       --  Do the necessary initializations
1371
1372       Clean.Initialize;
1373
1374       --  Parse the command line, getting the switches and the executable names
1375
1376       Parse_Cmd_Line;
1377
1378       if Verbose_Mode then
1379          Display_Copyright;
1380       end if;
1381
1382       if Project_File_Name /= null then
1383
1384          --  A project file was specified by a -P switch
1385
1386          if Opt.Verbose_Mode then
1387             New_Line;
1388             Put ("Parsing Project File """);
1389             Put (Project_File_Name.all);
1390             Put_Line (""".");
1391             New_Line;
1392          end if;
1393
1394          --  Set the project parsing verbosity to whatever was specified
1395          --  by a possible -vP switch.
1396
1397          Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1398
1399          --  Parse the project file. If there is an error, Main_Project
1400          --  will still be No_Project.
1401
1402          Prj.Pars.Parse
1403            (Project           => Main_Project,
1404             In_Tree           => Project_Tree,
1405             Project_File_Name => Project_File_Name.all,
1406             Flags             => Gnatmake_Flags,
1407             Packages_To_Check => Packages_To_Check_By_Gnatmake);
1408
1409          if Main_Project = No_Project then
1410             Fail ("""" & Project_File_Name.all & """ processing failed");
1411          end if;
1412
1413          if Opt.Verbose_Mode then
1414             New_Line;
1415             Put ("Parsing of Project File """);
1416             Put (Project_File_Name.all);
1417             Put (""" is finished.");
1418             New_Line;
1419          end if;
1420
1421          --  Add source directories and object directories to the search paths
1422
1423          Add_Source_Directories (Main_Project, Project_Tree);
1424          Add_Object_Directories (Main_Project);
1425       end if;
1426
1427       Osint.Add_Default_Search_Dirs;
1428
1429       --  If a project file was specified, but no executable name, put all
1430       --  the mains of the project file (if any) as if there were on the
1431       --  command line.
1432
1433       if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
1434          declare
1435             Main  : String_Element;
1436             Value : String_List_Id := Main_Project.Mains;
1437          begin
1438             while Value /= Prj.Nil_String loop
1439                Main := Project_Tree.String_Elements.Table (Value);
1440                Osint.Add_File
1441                  (File_Name => Get_Name_String (Main.Value),
1442                   Index     => Main.Index);
1443                Value := Main.Next;
1444             end loop;
1445          end;
1446       end if;
1447
1448       --  If neither a project file nor an executable were specified, output
1449       --  the usage and exit.
1450
1451       if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then
1452          Usage;
1453          return;
1454       end if;
1455
1456       if Verbose_Mode then
1457          New_Line;
1458       end if;
1459
1460       if Main_Project /= No_Project then
1461
1462          --  If a project file has been specified, call Clean_Project with the
1463          --  project id of this project file, after resetting the list of
1464          --  processed projects.
1465
1466          Processed_Projects.Init;
1467          Clean_Project (Main_Project);
1468
1469       else
1470          --  If no project file has been specified, the work is done in
1471          --  Clean_Executables.
1472
1473          Clean_Executables;
1474       end if;
1475
1476       --  In verbose mode, if Delete has not been called, indicate that no file
1477       --  needs to be deleted.
1478
1479       if Verbose_Mode and (not File_Deleted) then
1480          New_Line;
1481
1482          if Do_Nothing then
1483             Put_Line ("No file needs to be deleted");
1484          else
1485             Put_Line ("No file has been deleted");
1486          end if;
1487       end if;
1488    end Gnatclean;
1489
1490    ------------------------
1491    -- In_Extension_Chain --
1492    ------------------------
1493
1494    function In_Extension_Chain
1495      (Of_Project : Project_Id;
1496       Prj        : Project_Id) return Boolean
1497    is
1498       Proj : Project_Id;
1499
1500    begin
1501       if Prj = No_Project or else Of_Project = No_Project then
1502          return False;
1503       end if;
1504
1505       if Of_Project = Prj then
1506          return True;
1507       end if;
1508
1509       Proj := Of_Project;
1510       while Proj.Extends /= No_Project loop
1511          if Proj.Extends = Prj then
1512             return True;
1513          end if;
1514
1515          Proj := Proj.Extends;
1516       end loop;
1517
1518       Proj := Prj;
1519       while Proj.Extends /= No_Project loop
1520          if Proj.Extends = Of_Project then
1521             return True;
1522          end if;
1523
1524          Proj := Proj.Extends;
1525       end loop;
1526
1527       return False;
1528    end In_Extension_Chain;
1529
1530    ------------
1531    -- Init_Q --
1532    ------------
1533
1534    procedure Init_Q is
1535    begin
1536       Q_Front := Q.First;
1537       Q.Set_Last (Q.First);
1538    end Init_Q;
1539
1540    ----------------
1541    -- Initialize --
1542    ----------------
1543
1544    procedure Initialize is
1545    begin
1546       if not Initialized then
1547          Initialized := True;
1548
1549          --  Get default search directories to locate system.ads when calling
1550          --  Targparm.Get_Target_Parameters.
1551
1552          Osint.Add_Default_Search_Dirs;
1553
1554          --  Initialize some packages
1555
1556          Csets.Initialize;
1557          Namet.Initialize;
1558          Snames.Initialize;
1559          Prj.Initialize (Project_Tree);
1560
1561          --  Check if the platform is VMS and, if it is, change some variables
1562
1563          Targparm.Get_Target_Parameters;
1564
1565          if OpenVMS_On_Target then
1566             Debug_Suffix (Debug_Suffix'First) := '_';
1567             Repinfo_Suffix (Repinfo_Suffix'First) := '_';
1568             B_Start := new String'("b__");
1569          end if;
1570       end if;
1571
1572       --  Reset global variables
1573
1574       Free (Object_Directory_Path);
1575       Do_Nothing := False;
1576       File_Deleted := False;
1577       Copyright_Displayed := False;
1578       Usage_Displayed := False;
1579       Free (Project_File_Name);
1580       Main_Project := Prj.No_Project;
1581       All_Projects := False;
1582    end Initialize;
1583
1584    --------------
1585    -- Insert_Q --
1586    --------------
1587
1588    procedure Insert_Q (Lib_File : File_Name_Type) is
1589    begin
1590       --  Do not insert an empty name or an already marked source
1591
1592       if Lib_File /= No_File and then not Makeutl.Is_Marked (Lib_File) then
1593          Q.Table (Q.Last) := Lib_File;
1594          Q.Increment_Last;
1595
1596          --  Mark the source that has been just added to the Q
1597
1598          Makeutl.Mark (Lib_File);
1599       end if;
1600    end Insert_Q;
1601
1602    ----------------------
1603    -- Object_File_Name --
1604    ----------------------
1605
1606    function Object_File_Name (Source : File_Name_Type) return String is
1607       Src : constant String := Get_Name_String (Source);
1608
1609    begin
1610       --  If the source name has an extension, then replace it with
1611       --  the Object suffix.
1612
1613       for Index in reverse Src'First + 1 .. Src'Last loop
1614          if Src (Index) = '.' then
1615             return Src (Src'First .. Index - 1) & Object_Suffix;
1616          end if;
1617       end loop;
1618
1619       --  If there is no dot, or if it is the first character, just add the
1620       --  ALI suffix.
1621
1622       return Src & Object_Suffix;
1623    end Object_File_Name;
1624
1625    --------------------
1626    -- Parse_Cmd_Line --
1627    --------------------
1628
1629    procedure Parse_Cmd_Line is
1630       Last         : constant Natural := Argument_Count;
1631       Source_Index : Int := 0;
1632       Index        : Positive;
1633
1634       procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1635
1636    begin
1637       --  First, check for --version and --help
1638
1639       Check_Version_And_Help ("GNATCLEAN", "2003");
1640
1641       Index := 1;
1642       while Index <= Last loop
1643          declare
1644             Arg : constant String := Argument (Index);
1645
1646             procedure Bad_Argument;
1647             --  Signal bad argument
1648
1649             ------------------
1650             -- Bad_Argument --
1651             ------------------
1652
1653             procedure Bad_Argument is
1654             begin
1655                Fail ("invalid argument """ & Arg & """");
1656             end Bad_Argument;
1657
1658          begin
1659             if Arg'Length /= 0 then
1660                if Arg (1) = '-' then
1661                   if Arg'Length = 1 then
1662                      Bad_Argument;
1663                   end if;
1664
1665                   case Arg (2) is
1666                      when '-' =>
1667                         if Arg'Length > Subdirs_Option'Length and then
1668                           Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
1669                         then
1670                            Subdirs :=
1671                              new String'
1672                                (Arg (Subdirs_Option'Length + 1 .. Arg'Last));
1673
1674                         else
1675                            Bad_Argument;
1676                         end if;
1677
1678                      when 'a' =>
1679                         if Arg'Length < 4 then
1680                            Bad_Argument;
1681                         end if;
1682
1683                         if Arg (3) = 'O' then
1684                            Add_Lib_Search_Dir (Arg (4 .. Arg'Last));
1685
1686                         elsif Arg (3) = 'P' then
1687                            Prj.Ext.Add_Search_Project_Directory
1688                              (Arg (4 .. Arg'Last));
1689
1690                         else
1691                            Bad_Argument;
1692                         end if;
1693
1694                      when 'c'    =>
1695                         Compile_Only := True;
1696
1697                      when 'D'    =>
1698                         if Object_Directory_Path /= null then
1699                            Fail ("duplicate -D switch");
1700
1701                         elsif Project_File_Name /= null then
1702                            Fail ("-P and -D cannot be used simultaneously");
1703                         end if;
1704
1705                         if Arg'Length > 2 then
1706                            declare
1707                               Dir : constant String := Arg (3 .. Arg'Last);
1708                            begin
1709                               if not Is_Directory (Dir) then
1710                                  Fail (Dir & " is not a directory");
1711                               else
1712                                  Add_Lib_Search_Dir (Dir);
1713                               end if;
1714                            end;
1715
1716                         else
1717                            if Index = Last then
1718                               Fail ("no directory specified after -D");
1719                            end if;
1720
1721                            Index := Index + 1;
1722
1723                            declare
1724                               Dir : constant String := Argument (Index);
1725                            begin
1726                               if not Is_Directory (Dir) then
1727                                  Fail (Dir & " is not a directory");
1728                               else
1729                                  Add_Lib_Search_Dir (Dir);
1730                               end if;
1731                            end;
1732                         end if;
1733
1734                      when 'e' =>
1735                         if Arg = "-eL" then
1736                            Follow_Links_For_Files := True;
1737
1738                         else
1739                            Bad_Argument;
1740                         end if;
1741
1742                      when 'f' =>
1743                         Force_Deletions := True;
1744
1745                      when 'F' =>
1746                         Full_Path_Name_For_Brief_Errors := True;
1747
1748                      when 'h' =>
1749                         Usage;
1750
1751                      when 'i' =>
1752                         if Arg'Length = 2 then
1753                            Bad_Argument;
1754                         end if;
1755
1756                         Source_Index := 0;
1757
1758                         for J in 3 .. Arg'Last loop
1759                            if Arg (J) not in '0' .. '9' then
1760                               Bad_Argument;
1761                            end if;
1762
1763                            Source_Index :=
1764                              (20 * Source_Index) +
1765                              (Character'Pos (Arg (J)) - Character'Pos ('0'));
1766                         end loop;
1767
1768                      when 'I' =>
1769                         if Arg = "-I-" then
1770                            Opt.Look_In_Primary_Dir := False;
1771
1772                         else
1773                            if Arg'Length = 2 then
1774                               Bad_Argument;
1775                            end if;
1776
1777                            Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
1778                         end if;
1779
1780                      when 'n' =>
1781                         Do_Nothing := True;
1782
1783                      when 'P' =>
1784                         if Project_File_Name /= null then
1785                            Fail ("multiple -P switches");
1786
1787                         elsif Object_Directory_Path /= null then
1788                            Fail ("-D and -P cannot be used simultaneously");
1789
1790                         end if;
1791
1792                         if Arg'Length > 2 then
1793                            declare
1794                               Prj : constant String := Arg (3 .. Arg'Last);
1795                            begin
1796                               if Prj'Length > 1 and then
1797                                 Prj (Prj'First) = '='
1798                               then
1799                                  Project_File_Name :=
1800                                    new String'
1801                                      (Prj (Prj'First + 1 ..  Prj'Last));
1802                               else
1803                                  Project_File_Name := new String'(Prj);
1804                               end if;
1805                            end;
1806
1807                         else
1808                            if Index = Last then
1809                               Fail ("no project specified after -P");
1810                            end if;
1811
1812                            Index := Index + 1;
1813                            Project_File_Name := new String'(Argument (Index));
1814                         end if;
1815
1816                      when 'q' =>
1817                         Quiet_Output := True;
1818
1819                      when 'r' =>
1820                         All_Projects := True;
1821
1822                      when 'v' =>
1823                         if Arg = "-v" then
1824                            Verbose_Mode := True;
1825
1826                         elsif Arg = "-vP0" then
1827                            Current_Verbosity := Prj.Default;
1828
1829                         elsif Arg = "-vP1" then
1830                            Current_Verbosity := Prj.Medium;
1831
1832                         elsif Arg = "-vP2" then
1833                            Current_Verbosity := Prj.High;
1834
1835                         else
1836                            Bad_Argument;
1837                         end if;
1838
1839                      when 'X' =>
1840                         if Arg'Length = 2 then
1841                            Bad_Argument;
1842                         end if;
1843
1844                         declare
1845                            Ext_Asgn  : constant String := Arg (3 .. Arg'Last);
1846                            Start     : Positive := Ext_Asgn'First;
1847                            Stop      : Natural  := Ext_Asgn'Last;
1848                            Equal_Pos : Natural;
1849                            OK        : Boolean  := True;
1850
1851                         begin
1852                            if Ext_Asgn (Start) = '"' then
1853                               if Ext_Asgn (Stop) = '"' then
1854                                  Start := Start + 1;
1855                                  Stop  := Stop - 1;
1856
1857                               else
1858                                  OK := False;
1859                               end if;
1860                            end if;
1861
1862                            Equal_Pos := Start;
1863
1864                            while Equal_Pos <= Stop
1865                              and then Ext_Asgn (Equal_Pos) /= '='
1866                            loop
1867                               Equal_Pos := Equal_Pos + 1;
1868                            end loop;
1869
1870                            if Equal_Pos = Start or else Equal_Pos > Stop then
1871                               OK := False;
1872                            end if;
1873
1874                            if OK then
1875                               Prj.Ext.Add
1876                                 (External_Name =>
1877                                    Ext_Asgn (Start .. Equal_Pos - 1),
1878                                  Value         =>
1879                                    Ext_Asgn (Equal_Pos + 1 .. Stop));
1880
1881                            else
1882                               Fail
1883                                 ("illegal external assignment '"
1884                                  & Ext_Asgn
1885                                  & "'");
1886                            end if;
1887                         end;
1888
1889                      when others =>
1890                         Bad_Argument;
1891                   end case;
1892
1893                else
1894                   Add_File (Arg, Source_Index);
1895                end if;
1896             end if;
1897          end;
1898
1899          Index := Index + 1;
1900       end loop;
1901    end Parse_Cmd_Line;
1902
1903    -----------------------
1904    -- Repinfo_File_Name --
1905    -----------------------
1906
1907    function Repinfo_File_Name (Source : File_Name_Type) return String is
1908    begin
1909       return Get_Name_String (Source) & Repinfo_Suffix;
1910    end Repinfo_File_Name;
1911
1912    --------------------
1913    -- Tree_File_Name --
1914    --------------------
1915
1916    function Tree_File_Name (Source : File_Name_Type) return String is
1917       Src : constant String := Get_Name_String (Source);
1918
1919    begin
1920       --  If source name has an extension, then replace it with the tree suffix
1921
1922       for Index in reverse Src'First + 1 .. Src'Last loop
1923          if Src (Index) = '.' then
1924             return Src (Src'First .. Index - 1) & Tree_Suffix;
1925          end if;
1926       end loop;
1927
1928       --  If there is no dot, or if it is the first character, just add the
1929       --  tree suffix.
1930
1931       return Src & Tree_Suffix;
1932    end Tree_File_Name;
1933
1934    -----------
1935    -- Usage --
1936    -----------
1937
1938    procedure Usage is
1939    begin
1940       if not Usage_Displayed then
1941          Usage_Displayed := True;
1942          Display_Copyright;
1943          Put_Line ("Usage: gnatclean [switches] {[-innn] name}");
1944          New_Line;
1945
1946          Put_Line ("  names is one or more file names from which " &
1947                    "the .adb or .ads suffix may be omitted");
1948          Put_Line ("  names may be omitted if -P<project> is specified");
1949          New_Line;
1950
1951          Put_Line ("  --subdirs=dir real obj/lib/exec dirs are subdirs");
1952          New_Line;
1953
1954          Put_Line ("  -c       Only delete compiler generated files");
1955          Put_Line ("  -D dir   Specify dir as the object library");
1956          Put_Line ("  -eL      Follow symbolic links when processing " &
1957                    "project files");
1958          Put_Line ("  -f       Force deletions of unwritable files");
1959          Put_Line ("  -F       Full project path name " &
1960                    "in brief error messages");
1961          Put_Line ("  -h       Display this message");
1962          Put_Line ("  -innn    Index of unit in source for following names");
1963          Put_Line ("  -n       Nothing to do: only list files to delete");
1964          Put_Line ("  -Pproj   Use GNAT Project File proj");
1965          Put_Line ("  -q       Be quiet/terse");
1966          Put_Line ("  -r       Clean all projects recursively");
1967          Put_Line ("  -v       Verbose mode");
1968          Put_Line ("  -vPx     Specify verbosity when parsing " &
1969                    "GNAT Project Files");
1970          Put_Line ("  -Xnm=val Specify an external reference " &
1971                    "for GNAT Project Files");
1972          New_Line;
1973
1974          Put_Line ("  -aPdir   Add directory dir to project search path");
1975          New_Line;
1976
1977          Put_Line ("  -aOdir   Specify ALI/object files search path");
1978          Put_Line ("  -Idir    Like -aOdir");
1979          Put_Line ("  -I-      Don't look for source/library files " &
1980                    "in the default directory");
1981          New_Line;
1982       end if;
1983    end Usage;
1984
1985 end Clean;