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