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