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