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