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-2004, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Ada.Command_Line; use Ada.Command_Line;
  28
  29 with ALI;      use ALI;
  30 with Csets;
  31 with Gnatvsn;
  32 with Hostparm;
  33 with Makeutl;  use Makeutl;
  34 with Namet;    use Namet;
  35 with Opt;      use Opt;
  36 with Osint;    use Osint;
  37 with Osint.M;  use Osint.M;
  38 with Prj;      use Prj;
  39 with Prj.Com;
  40 with Prj.Env;
  41 with Prj.Ext;
  42 with Prj.Pars;
  43 with Prj.Util; use Prj.Util;
  44 with Snames;
  45 with System;
  46 with Table;
  47 with Types;    use Types;
  48
  49 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  50 with GNAT.IO;                   use GNAT.IO;
  51 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  52
  53 package body Clean is
  54
  55    Initialized : Boolean := False;
  56    --  Set to True by the first call to Initialize.
  57    --  To avoid reinitialization of some packages.
  58
  59    --  Suffixes of various files
  60
  61    Assembly_Suffix : constant String := ".s";
  62    ALI_Suffix      : constant String := ".ali";
  63    Tree_Suffix     : constant String := ".adt";
  64    Object_Suffix   : constant String := Get_Object_Suffix.all;
  65    Debug_Suffix    : String          := ".dg";
  66    --  Changed to "_dg" for VMS in the body of the package
  67
  68    Repinfo_Suffix  : String          := ".rep";
  69    --  Changed to "_rep" for VMS in the body of the package
  70
  71    B_Start : String := "b~";
  72    --  Prefix of binder generated file.
  73    --  Changed to "b$" for VMS in the body of the package.
  74
  75    Object_Directory_Path : String_Access := null;
  76    --  The path name of the object directory, set with switch -D
  77
  78    Do_Nothing : Boolean := False;
  79    --  Set to True when switch -n is specified.
  80    --  When True, no file is deleted. gnatclean only lists the files that
  81    --  would have been deleted if the switch -n had not been specified.
  82
  83    File_Deleted : Boolean := False;
  84    --  Set to True if at least one file has been deleted
  85
  86    Copyright_Displayed : Boolean := False;
  87    Usage_Displayed     : Boolean := False;
  88
  89    Project_File_Name : String_Access := null;
  90
  91    Main_Project : Prj.Project_Id := Prj.No_Project;
  92
  93    All_Projects : Boolean := False;
  94
  95    --  Packages of project files where unknown attributes are errors.
  96
  97    Naming_String   : aliased String := "naming";
  98    Builder_String  : aliased String := "builder";
  99    Compiler_String : aliased String := "compiler";
 100    Binder_String   : aliased String := "binder";
 101    Linker_String   : aliased String := "linker";
 102
 103    Gnatmake_Packages : aliased String_List :=
 104      (Naming_String   'Access,
 105       Builder_String  'Access,
 106       Compiler_String 'Access,
 107       Binder_String   'Access,
 108       Linker_String   'Access);
 109
 110    Packages_To_Check_By_Gnatmake : constant String_List_Access :=
 111      Gnatmake_Packages'Access;
 112
 113    package Processed_Projects is new Table.Table
 114      (Table_Component_Type => Project_Id,
 115       Table_Index_Type     => Natural,
 116       Table_Low_Bound      => 0,
 117       Table_Initial        => 10,
 118       Table_Increment      => 10,
 119       Table_Name           => "Clean.Processed_Projects");
 120    --  Table to keep track of what project files have been processed, when
 121    --  switch -r is specified.
 122
 123    package Sources is new Table.Table
 124      (Table_Component_Type => File_Name_Type,
 125       Table_Index_Type     => Natural,
 126       Table_Low_Bound      => 0,
 127       Table_Initial        => 10,
 128       Table_Increment      => 10,
 129       Table_Name           => "Clean.Processed_Projects");
 130    --  Table to store all the source files of a library unit: spec, body and
 131    --  subunits, to detect .dg files and delete them.
 132
 133    ----------------------------
 134    -- Queue (Q) manipulation --
 135    ----------------------------
 136
 137    procedure Init_Q;
 138    --  Must be called to initialize the Q
 139
 140    procedure Insert_Q (Lib_File  : File_Name_Type);
 141    --  If Lib_File is not marked, inserts it at the end of Q and mark it
 142
 143    function Empty_Q return Boolean;
 144    --  Returns True if Q is empty.
 145
 146    procedure Extract_From_Q (Lib_File : out File_Name_Type);
 147    --  Extracts the first element from the Q.
 148
 149    Q_Front : Natural;
 150    --  Points to the first valid element in the Q.
 151
 152    package Q is new Table.Table (
 153      Table_Component_Type => File_Name_Type,
 154      Table_Index_Type     => Natural,
 155      Table_Low_Bound      => 0,
 156      Table_Initial        => 4000,
 157      Table_Increment      => 100,
 158      Table_Name           => "Clean.Q");
 159    --  This is the actual queue
 160
 161    -----------------------------
 162    -- Other local subprograms --
 163    -----------------------------
 164
 165    procedure Add_Source_Dir (N : String);
 166    --  Call Add_Src_Search_Dir.
 167    --  Output one line when in verbose mode.
 168
 169    procedure Add_Source_Directories is
 170      new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir);
 171
 172    procedure Add_Object_Dir (N : String);
 173    --  Call Add_Lib_Search_Dir.
 174    --  Output one line when in verbose mode.
 175
 176    procedure Add_Object_Directories is
 177      new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
 178
 179    function ALI_File_Name (Source : Name_Id) return String;
 180    --  Returns the name of the ALI file corresponding to Source
 181
 182    function Assembly_File_Name (Source : Name_Id) return String;
 183    --  Returns the assembly file name corresponding to Source
 184
 185    procedure Clean_Directory (Dir : Name_Id);
 186    --  Delete all regular files in a library directory or in a library
 187    --  interface dir.
 188
 189    procedure Clean_Executables;
 190    --  Do the cleaning work when no project file is specified
 191
 192    procedure Clean_Project (Project : Project_Id);
 193    --  Do the cleaning work when a project file is specified.
 194    --  This procedure calls itself recursively when there are several
 195    --  project files in the tree rooted at the main project file and switch -r
 196    --  has been specified.
 197
 198    function Debug_File_Name (Source : Name_Id) return String;
 199    --  Name of the expanded source file corresponding to Source
 200
 201    procedure Delete (In_Directory : String; File : String);
 202    --  Delete one file, or list the file name if switch -n is specified
 203
 204    procedure Delete_Binder_Generated_Files (Dir : String; Source : Name_Id);
 205    --  Delete the binder generated file in directory Dir for Source, if they
 206    --  exist: for Unix these are b~<source>.ads, b~<source>.adb,
 207    --  b~<source>.ali and b~<source>.o.
 208
 209    procedure Display_Copyright;
 210    --  Display the Copyright notice.
 211    --  If called several times, display the Copyright notice only the first
 212    --  time.
 213
 214    procedure Initialize;
 215    --  Call the necessary package initializations
 216
 217    function Object_File_Name (Source : Name_Id) return String;
 218    --  Returns the object file name corresponding to Source
 219
 220    procedure Parse_Cmd_Line;
 221    --  Parse the command line
 222
 223    function Repinfo_File_Name (Source : Name_Id) return String;
 224    --  Returns the repinfo file name corresponding to Source
 225
 226    function Tree_File_Name (Source : Name_Id) return String;
 227    --  Returns the tree file name corresponding to Source
 228
 229    function In_Extension_Chain
 230      (Of_Project : Project_Id;
 231       Prj        : Project_Id) return Boolean;
 232    --  Returns True iff Prj is an extension of Of_Project or if Of_Project is
 233    --  an extension of Prj.
 234
 235    procedure Usage;
 236    --  Display the usage.
 237    --  If called several times, the usage is displayed only the first time.
 238
 239    --------------------
 240    -- Add_Object_Dir --
 241    --------------------
 242
 243    procedure Add_Object_Dir (N : String) is
 244    begin
 245       Add_Lib_Search_Dir (N);
 246
 247       if Opt.Verbose_Mode then
 248          Put ("Adding object directory """);
 249          Put (N);
 250          Put (""".");
 251          New_Line;
 252       end if;
 253    end Add_Object_Dir;
 254
 255    --------------------
 256    -- Add_Source_Dir --
 257    --------------------
 258
 259    procedure Add_Source_Dir (N : String) is
 260    begin
 261       Add_Src_Search_Dir (N);
 262
 263       if Opt.Verbose_Mode then
 264          Put ("Adding source directory """);
 265          Put (N);
 266          Put (""".");
 267          New_Line;
 268       end if;
 269    end Add_Source_Dir;
 270
 271    -------------------
 272    -- ALI_File_Name --
 273    -------------------
 274
 275    function ALI_File_Name (Source : Name_Id) return String is
 276       Src : constant String := Get_Name_String (Source);
 277
 278    begin
 279       --  If the source name has an extension, then replace it with
 280       --  the ALI suffix.
 281
 282       for Index in reverse Src'First + 1 .. Src'Last loop
 283          if Src (Index) = '.' then
 284             return Src (Src'First .. Index - 1) & ALI_Suffix;
 285          end if;
 286       end loop;
 287
 288       --  If there is no dot, or if it is the first character, just add the
 289       --  ALI suffix.
 290
 291       return Src & ALI_Suffix;
 292    end ALI_File_Name;
 293
 294    ------------------------
 295    -- Assembly_File_Name --
 296    ------------------------
 297
 298    function Assembly_File_Name (Source : Name_Id) return String is
 299       Src : constant String := Get_Name_String (Source);
 300
 301    begin
 302       --  If the source name has an extension, then replace it with
 303       --  the assembly suffix.
 304
 305       for Index in reverse Src'First + 1 .. Src'Last loop
 306          if Src (Index) = '.' then
 307             return Src (Src'First .. Index - 1) & Assembly_Suffix;
 308          end if;
 309       end loop;
 310
 311       --  If there is no dot, or if it is the first character, just add the
 312       --  assembly suffix.
 313
 314       return Src & Assembly_Suffix;
 315    end Assembly_File_Name;
 316
 317    ---------------------
 318    -- Clean_Directory --
 319    ---------------------
 320
 321    procedure Clean_Directory (Dir : Name_Id) is
 322       Directory : constant String := Get_Name_String (Dir);
 323       Current   : constant Dir_Name_Str := Get_Current_Dir;
 324
 325       Direc : Dir_Type;
 326
 327       Name : String (1 .. 200);
 328       Last : Natural;
 329
 330       procedure Set_Writable (Name : System.Address);
 331       pragma Import (C, Set_Writable, "__gnat_set_writable");
 332
 333    begin
 334       Change_Dir (Directory);
 335       Open (Direc, ".");
 336
 337       --  For each regular file in the directory, if switch -n has not been
 338       --  specified, make it writable and delete the file.
 339
 340       loop
 341          Read (Direc, Name, Last);
 342          exit when Last = 0;
 343
 344          if Is_Regular_File (Name (1 .. Last)) then
 345             if not Do_Nothing then
 346                Name (Last + 1) := ASCII.NUL;
 347                Set_Writable (Name (1)'Address);
 348             end if;
 349
 350             Delete (Directory, Name (1 .. Last));
 351          end if;
 352       end loop;
 353
 354       Close (Direc);
 355
 356       --  Restore the initial working directory
 357
 358       Change_Dir (Current);
 359    end Clean_Directory;
 360
 361    -----------------------
 362    -- Clean_Executables --
 363    -----------------------
 364
 365    procedure Clean_Executables is
 366       Main_Source_File : File_Name_Type;
 367       --  Current main source
 368
 369       Main_Lib_File : File_Name_Type;
 370       --  ALI file of the current main
 371
 372       Lib_File : File_Name_Type;
 373       --  Current ALI file
 374
 375       Full_Lib_File : File_Name_Type;
 376       --  Full name of the current ALI file
 377
 378       Text : Text_Buffer_Ptr;
 379       The_ALI : ALI_Id;
 380
 381    begin
 382       Init_Q;
 383
 384       --  It does not really matter if there is or not an object file
 385       --  corresponding to an ALI file: if there is one, it will be deleted.
 386
 387       Opt.Check_Object_Consistency := False;
 388
 389       --  Proceed each executable one by one. Each source is marked as it is
 390       --  processed, so common sources between executables will not be
 391       --  processed several times.
 392
 393       for N_File in 1 .. Osint.Number_Of_Files loop
 394          Main_Source_File := Next_Main_Source;
 395          Main_Lib_File := Osint.Lib_File_Name
 396                              (Main_Source_File, Current_File_Index);
 397          Insert_Q (Main_Lib_File);
 398
 399          while not Empty_Q loop
 400             Sources.Set_Last (0);
 401             Extract_From_Q (Lib_File);
 402             Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
 403
 404             --  If we have an existing ALI file that is not read-only,
 405             --  process it.
 406
 407             if Full_Lib_File /= No_File
 408               and then not Is_Readonly_Library (Full_Lib_File)
 409             then
 410                Text := Read_Library_Info (Lib_File);
 411
 412                if Text /= null then
 413                   The_ALI :=
 414                     Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
 415                   Free (Text);
 416
 417                   --  If no error was produced while loading this ALI file,
 418                   --  insert into the queue all the unmarked withed sources.
 419
 420                   if The_ALI /= No_ALI_Id then
 421                      for J in ALIs.Table (The_ALI).First_Unit ..
 422                        ALIs.Table (The_ALI).Last_Unit
 423                      loop
 424                         Sources.Increment_Last;
 425                         Sources.Table (Sources.Last) :=
 426                           ALI.Units.Table (J).Sfile;
 427
 428                         for K in ALI.Units.Table (J).First_With ..
 429                           ALI.Units.Table (J).Last_With
 430                         loop
 431                            Insert_Q (Withs.Table (K).Afile);
 432                         end loop;
 433                      end loop;
 434
 435                      --  Look for subunits and put them in the Sources table
 436
 437                      for J in ALIs.Table (The_ALI).First_Sdep ..
 438                        ALIs.Table (The_ALI).Last_Sdep
 439                      loop
 440                         if Sdep.Table (J).Subunit_Name /= No_Name then
 441                            Sources.Increment_Last;
 442                            Sources.Table (Sources.Last) :=
 443                              Sdep.Table (J).Sfile;
 444                         end if;
 445                      end loop;
 446                   end if;
 447                end if;
 448
 449                --  Now, delete all the existing files corresponding to this
 450                --  ALI file.
 451
 452                declare
 453                   Obj_Dir : constant String :=
 454                               Dir_Name (Get_Name_String (Full_Lib_File));
 455                   Obj     : constant String := Object_File_Name (Lib_File);
 456                   Adt     : constant String := Tree_File_Name   (Lib_File);
 457                   Asm     : constant String := Assembly_File_Name (Lib_File);
 458
 459                begin
 460                   Delete (Obj_Dir, Get_Name_String (Lib_File));
 461
 462                   if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then
 463                      Delete (Obj_Dir, Obj);
 464                   end if;
 465
 466                   if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then
 467                      Delete (Obj_Dir, Adt);
 468                   end if;
 469
 470                   if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then
 471                      Delete (Obj_Dir, Asm);
 472                   end if;
 473
 474                   --  Delete expanded source files (.dg) and/or repinfo files
 475                   --  (.rep) if any
 476
 477                   for J in 1 .. Sources.Last loop
 478                      declare
 479                         Deb : constant String :=
 480                                          Debug_File_Name (Sources.Table (J));
 481                         Rep : constant String :=
 482                                          Repinfo_File_Name (Sources.Table (J));
 483                      begin
 484                         if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
 485                            Delete (Obj_Dir, Deb);
 486                         end if;
 487
 488                         if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then
 489                            Delete (Obj_Dir, Rep);
 490                         end if;
 491                      end;
 492                   end loop;
 493                end;
 494             end if;
 495          end loop;
 496
 497          --  Delete the executable, if it exists, and the binder generated
 498          --  files, if any.
 499
 500          if not Compile_Only then
 501             declare
 502                Source : constant Name_Id := Strip_Suffix (Main_Lib_File);
 503                Executable : constant String := Get_Name_String
 504                                               (Executable_Name (Source));
 505             begin
 506                if Is_Regular_File (Executable) then
 507                   Delete ("", Executable);
 508                end if;
 509
 510                Delete_Binder_Generated_Files (Get_Current_Dir, Source);
 511             end;
 512          end if;
 513       end loop;
 514    end Clean_Executables;
 515
 516    -------------------
 517    -- Clean_Project --
 518    -------------------
 519
 520    procedure Clean_Project (Project : Project_Id) is
 521       Main_Source_File : File_Name_Type;
 522       --  Name of the executable on the command line, without directory
 523       --  information.
 524
 525       Executable : Name_Id;
 526       --  Name of the executable file
 527
 528       Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
 529       Data        : constant Project_Data := Projects.Table (Project);
 530       U_Data      : Prj.Com.Unit_Data;
 531       File_Name1  : Name_Id;
 532       Index1      : Int;
 533       File_Name2  : Name_Id;
 534       Index2      : Int;
 535       Lib_File    : File_Name_Type;
 536
 537       use Prj.Com;
 538
 539    begin
 540       --  Check that we don't specify executable on the command line for
 541       --  a main library project.
 542
 543       if Project = Main_Project
 544         and then Osint.Number_Of_Files /= 0
 545         and then Data.Library
 546       then
 547          Osint.Fail
 548            ("Cannot specify executable(s) for a Library Project File");
 549       end if;
 550
 551       if Verbose_Mode then
 552          Put ("Cleaning project """);
 553          Put (Get_Name_String (Data.Name));
 554          Put_Line ("""");
 555       end if;
 556
 557       --  Add project to the list of proceesed projects
 558
 559       Processed_Projects.Increment_Last;
 560       Processed_Projects.Table (Processed_Projects.Last) := Project;
 561
 562       if Data.Object_Directory /= No_Name then
 563          declare
 564             Obj_Dir : constant String :=
 565                         Get_Name_String (Data.Object_Directory);
 566
 567          begin
 568             Change_Dir (Obj_Dir);
 569
 570             --  Look through the units to find those that are either immediate
 571             --  sources or inherited sources of the project.
 572
 573             for Unit in 1 .. Prj.Com.Units.Last loop
 574                U_Data := Prj.Com.Units.Table (Unit);
 575                File_Name1 := No_Name;
 576                File_Name2 := No_Name;
 577
 578                --  If either the spec or the body is a source of the project,
 579                --  check for the corresponding ALI file in the object
 580                --  directory.
 581
 582                if In_Extension_Chain
 583                  (U_Data.File_Names (Body_Part).Project, Project)
 584                  or else
 585                    In_Extension_Chain
 586                      (U_Data.File_Names (Specification).Project, Project)
 587                then
 588                   File_Name1 := U_Data.File_Names (Body_Part).Name;
 589                   Index1     := U_Data.File_Names (Body_Part).Index;
 590                   File_Name2 := U_Data.File_Names (Specification).Name;
 591                   Index2     := U_Data.File_Names (Specification).Index;
 592
 593                   --  If there is no body file name, then there may be only a
 594                   --  spec.
 595
 596                   if File_Name1 = No_Name then
 597                      File_Name1 := File_Name2;
 598                      Index1     := Index2;
 599                      File_Name2 := No_Name;
 600                      Index2     := 0;
 601                   end if;
 602                end if;
 603
 604                --  If there is either a spec or a body, look for files in the
 605                --  object directory.
 606
 607                if File_Name1 /= No_Name then
 608                   Lib_File := Osint.Lib_File_Name (File_Name1, Index1);
 609
 610                   declare
 611                      Asm : constant String := Assembly_File_Name (Lib_File);
 612                      ALI : constant String := ALI_File_Name      (Lib_File);
 613                      Obj : constant String := Object_File_Name   (Lib_File);
 614                      Adt : constant String := Tree_File_Name     (Lib_File);
 615                      Deb : constant String := Debug_File_Name    (File_Name1);
 616                      Rep : constant String := Repinfo_File_Name  (File_Name1);
 617                      Del : Boolean := True;
 618
 619                   begin
 620                      --  If the ALI file exists and is read-only, no file is
 621                      --  deleted.
 622
 623                      if Is_Regular_File (ALI) then
 624                         if Is_Writable_File (ALI) then
 625                            Delete (Obj_Dir, ALI);
 626
 627                         else
 628                            Del := False;
 629
 630                            if Verbose_Mode then
 631                               Put ('"');
 632                               Put (Obj_Dir);
 633
 634                               if Obj_Dir (Obj_Dir'Last) /= Dir_Separator then
 635                                  Put (Dir_Separator);
 636                               end if;
 637
 638                               Put (ALI);
 639                               Put_Line (""" is read-only");
 640                            end if;
 641                         end if;
 642                      end if;
 643
 644                      if Del then
 645
 646                         --  Object file
 647
 648                         if Is_Regular_File (Obj) then
 649                            Delete (Obj_Dir, Obj);
 650                         end if;
 651
 652                         --  Assembly file
 653
 654                         if Is_Regular_File (Asm) then
 655                            Delete (Obj_Dir, Asm);
 656                         end if;
 657
 658                         --  Tree file
 659
 660                         if Is_Regular_File (Adt) then
 661                            Delete (Obj_Dir, Adt);
 662                         end if;
 663
 664                         --  First expanded source file
 665
 666                         if Is_Regular_File (Deb) then
 667                            Delete (Obj_Dir, Deb);
 668                         end if;
 669
 670                         --  Repinfo file
 671
 672                         if Is_Regular_File (Rep) then
 673                            Delete (Obj_Dir, Rep);
 674                         end if;
 675
 676                         --  Second expanded source file
 677
 678                         if File_Name2 /= No_Name then
 679                            declare
 680                               Deb : constant String :=
 681                                       Debug_File_Name   (File_Name2);
 682                               Rep : constant String :=
 683                                       Repinfo_File_Name (File_Name2);
 684                            begin
 685                               if Is_Regular_File (Deb) then
 686                                  Delete (Obj_Dir, Deb);
 687                               end if;
 688
 689                               if Is_Regular_File (Rep) then
 690                                  Delete (Obj_Dir, Rep);
 691                               end if;
 692                            end;
 693                         end if;
 694                      end if;
 695                   end;
 696                end if;
 697             end loop;
 698
 699             if Verbose_Mode then
 700                New_Line;
 701             end if;
 702          end;
 703       end if;
 704
 705       --  If switch -r is specified, call Clean_Project recursively for the
 706       --  imported projects and the project being extended.
 707
 708       if All_Projects then
 709          declare
 710             Imported : Project_List := Data.Imported_Projects;
 711             Element  : Project_Element;
 712             Process  : Boolean;
 713
 714          begin
 715             --  For each imported project, call Clean_Project if the project
 716             --  has not been processed already.
 717
 718             while Imported /= Empty_Project_List loop
 719                Element := Project_Lists.Table (Imported);
 720                Imported := Element.Next;
 721                Process := True;
 722
 723                for
 724                  J in Processed_Projects.First .. Processed_Projects.Last
 725                loop
 726                   if Element.Project = Processed_Projects.Table (J) then
 727                      Process := False;
 728                      exit;
 729                   end if;
 730                end loop;
 731
 732                if Process then
 733                   Clean_Project (Element.Project);
 734                end if;
 735             end loop;
 736
 737             --  If this project extends another project, call Clean_Project for
 738             --  the project being extended. It is guaranteed that it has not
 739             --  called before, because no other project may import or extend
 740             --  this project.
 741
 742             if Data.Extends /= No_Project then
 743                Clean_Project (Data.Extends);
 744             end if;
 745          end;
 746       end if;
 747
 748       --  If this is a library project, clean the library directory, the
 749       --  interface copy dir and, for a Stand-Alone Library, the binder
 750       --  generated files of the library.
 751
 752       --  The directories are cleaned only if switch -c is not specified.
 753
 754       if Data.Library then
 755          if not Compile_Only then
 756             Clean_Directory (Data.Library_Dir);
 757
 758             if Data.Library_Src_Dir /= No_Name
 759               and then Data.Library_Src_Dir /= Data.Library_Dir
 760             then
 761                Clean_Directory (Data.Library_Src_Dir);
 762             end if;
 763          end if;
 764
 765          if Data.Standalone_Library and then
 766             Data.Object_Directory /= No_Name
 767          then
 768             Delete_Binder_Generated_Files
 769               (Get_Name_String (Data.Object_Directory), Data.Library_Name);
 770          end if;
 771
 772          --  Otherwise, for the main project, delete the executables and the
 773          --  binder generated files.
 774
 775          --  The executables are deleted only if switch -c is not specified.
 776
 777       elsif Project = Main_Project and then Data.Exec_Directory /= No_Name then
 778          declare
 779             Exec_Dir : constant String :=
 780               Get_Name_String (Data.Exec_Directory);
 781          begin
 782             Change_Dir (Exec_Dir);
 783
 784             for N_File in 1 .. Osint.Number_Of_Files loop
 785                Main_Source_File := Next_Main_Source;
 786
 787                if not Compile_Only then
 788                   Executable :=
 789                     Executable_Of
 790                       (Main_Project,
 791                        Main_Source_File,
 792                        Current_File_Index);
 793
 794                   if Is_Regular_File (Get_Name_String (Executable)) then
 795                      Delete (Exec_Dir, Get_Name_String (Executable));
 796                   end if;
 797                end if;
 798
 799                if Data.Object_Directory /= No_Name then
 800                   Delete_Binder_Generated_Files
 801                     (Get_Name_String
 802                        (Data.Object_Directory),
 803                      Strip_Suffix (Main_Source_File));
 804                end if;
 805             end loop;
 806          end;
 807       end if;
 808
 809       --  Change back to previous directory
 810
 811       Change_Dir (Current_Dir);
 812    end Clean_Project;
 813
 814    ---------------------
 815    -- Debug_File_Name --
 816    ---------------------
 817
 818    function Debug_File_Name (Source : Name_Id) return String is
 819    begin
 820       return Get_Name_String (Source) & Debug_Suffix;
 821    end Debug_File_Name;
 822
 823    ------------
 824    -- Delete --
 825    ------------
 826
 827    procedure Delete (In_Directory : String; File : String) is
 828       Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
 829       Last : Natural := 0;
 830       Success : Boolean;
 831
 832    begin
 833       --  Indicate that at least one file is deleted or is to be deleted
 834
 835       File_Deleted := True;
 836
 837       --  Build the path name of the file to delete
 838
 839       Last := In_Directory'Length;
 840       Full_Name (1 .. Last) := In_Directory;
 841
 842       if Last > 0 and then Full_Name (Last) /= Directory_Separator then
 843          Last := Last + 1;
 844          Full_Name (Last) := Directory_Separator;
 845       end if;
 846
 847       Full_Name (Last + 1 .. Last + File'Length) := File;
 848       Last := Last + File'Length;
 849
 850       --  If switch -n was used, simply output the path name
 851
 852       if Do_Nothing then
 853          Put_Line (Full_Name (1 .. Last));
 854
 855       --  Otherwise, delete the file
 856
 857       else
 858          Delete_File (Full_Name (1 .. Last), Success);
 859
 860          if not Success then
 861             Put ("Warning: """);
 862             Put (Full_Name (1 .. Last));
 863             Put_Line (""" could not be deleted");
 864
 865          elsif Verbose_Mode or else not Quiet_Output then
 866             Put ("""");
 867             Put (Full_Name (1 .. Last));
 868             Put_Line (""" has been deleted");
 869          end if;
 870       end if;
 871    end Delete;
 872
 873    -----------------------------------
 874    -- Delete_Binder_Generated_Files --
 875    -----------------------------------
 876
 877    procedure Delete_Binder_Generated_Files (Dir : String; Source : Name_Id) is
 878       Source_Name : constant String := Get_Name_String (Source);
 879       Current     : constant String := Get_Current_Dir;
 880       Last        : constant Positive := B_Start'Length + Source_Name'Length;
 881       File_Name   : String (1 .. Last + 4);
 882
 883    begin
 884       Change_Dir (Dir);
 885
 886       --  Build the file name (before the extension)
 887
 888       File_Name (1 .. B_Start'Length) := B_Start;
 889       File_Name (B_Start'Length + 1 .. Last) := Source_Name;
 890
 891       --  Spec
 892
 893       File_Name (Last + 1 .. Last + 4) := ".ads";
 894
 895       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 896          Delete (Dir, File_Name (1 .. Last + 4));
 897       end if;
 898
 899       --  Body
 900
 901       File_Name (Last + 1 .. Last + 4) := ".adb";
 902
 903       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 904          Delete (Dir, File_Name (1 .. Last + 4));
 905       end if;
 906
 907       --  ALI file
 908
 909       File_Name (Last + 1 .. Last + 4) := ".ali";
 910
 911       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 912          Delete (Dir, File_Name (1 .. Last + 4));
 913       end if;
 914
 915       --  Object file
 916
 917       File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix;
 918
 919       if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then
 920          Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length));
 921       end if;
 922
 923       --  Change back to previous directory
 924
 925       Change_Dir (Current);
 926    end Delete_Binder_Generated_Files;
 927
 928    -----------------------
 929    -- Display_Copyright --
 930    -----------------------
 931
 932    procedure Display_Copyright is
 933    begin
 934       if not Copyright_Displayed then
 935          Copyright_Displayed := True;
 936          Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String
 937                    & " Copyright 2003-2004 Free Software Foundation, Inc.");
 938       end if;
 939    end Display_Copyright;
 940
 941    -------------
 942    -- Empty_Q --
 943    -------------
 944
 945    function Empty_Q return Boolean is
 946    begin
 947       return Q_Front >= Q.Last;
 948    end Empty_Q;
 949
 950    --------------------
 951    -- Extract_From_Q --
 952    --------------------
 953
 954    procedure Extract_From_Q (Lib_File : out File_Name_Type) is
 955       Lib : constant File_Name_Type := Q.Table (Q_Front);
 956
 957    begin
 958       Q_Front  := Q_Front + 1;
 959       Lib_File := Lib;
 960    end Extract_From_Q;
 961
 962    ---------------
 963    -- Gnatclean --
 964    ---------------
 965
 966    procedure Gnatclean is
 967    begin
 968       --  Do the necessary initializations
 969
 970       Initialize;
 971
 972       --  Parse the command line, getting the switches and the executable names
 973
 974       Parse_Cmd_Line;
 975
 976       if Verbose_Mode then
 977          Display_Copyright;
 978       end if;
 979
 980       if Project_File_Name /= null then
 981
 982          --  A project file was specified by a -P switch
 983
 984          if Opt.Verbose_Mode then
 985             New_Line;
 986             Put ("Parsing Project File """);
 987             Put (Project_File_Name.all);
 988             Put_Line (""".");
 989             New_Line;
 990          end if;
 991
 992          --  Set the project parsing verbosity to whatever was specified
 993          --  by a possible -vP switch.
 994
 995          Prj.Pars.Set_Verbosity (To => Prj.Com.Current_Verbosity);
 996
 997          --  Parse the project file.
 998          --  If there is an error, Main_Project will still be No_Project.
 999
1000          Prj.Pars.Parse
1001            (Project           => Main_Project,
1002             Project_File_Name => Project_File_Name.all,
1003             Packages_To_Check => Packages_To_Check_By_Gnatmake);
1004
1005          if Main_Project = No_Project then
1006             Fail ("""" & Project_File_Name.all &
1007                   """ processing failed");
1008          end if;
1009
1010          if Opt.Verbose_Mode then
1011             New_Line;
1012             Put ("Parsing of Project File """);
1013             Put (Project_File_Name.all);
1014             Put (""" is finished.");
1015             New_Line;
1016          end if;
1017
1018          --  We add the source directories and the object directories
1019          --  to the search paths.
1020
1021          Add_Source_Directories (Main_Project);
1022          Add_Object_Directories (Main_Project);
1023
1024       end if;
1025
1026       Osint.Add_Default_Search_Dirs;
1027
1028       --  If a project file was specified, but no executable name, put all
1029       --  the mains of the project file (if any) as if there were on the
1030       --  command line.
1031
1032       if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
1033          declare
1034             Value : String_List_Id := Projects.Table (Main_Project).Mains;
1035             Main  : String_Element;
1036          begin
1037             while Value /= Prj.Nil_String loop
1038                Main := String_Elements.Table (Value);
1039                Osint.Add_File
1040                  (File_Name => Get_Name_String (Main.Value),
1041                   Index     => Main.Index);
1042                Value := Main.Next;
1043             end loop;
1044          end;
1045       end if;
1046
1047       --  If neither a project file nor an executable were specified,
1048       --  output the usage and exit.
1049
1050       if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then
1051          Usage;
1052          return;
1053       end if;
1054
1055       if Verbose_Mode then
1056          New_Line;
1057       end if;
1058
1059       if Main_Project /= No_Project then
1060
1061          --  If a project file has been specified, call Clean_Project with the
1062          --  project id of this project file, after resetting the list of
1063          --  processed projects.
1064
1065          Processed_Projects.Init;
1066          Clean_Project (Main_Project);
1067
1068       else
1069          --  If no project file has been specified, the work is done in
1070          --  Clean_Executables.
1071
1072          Clean_Executables;
1073       end if;
1074
1075       --  In verbose mode, if Delete has not been called, indicate that
1076       --  no file needs to be deleted.
1077
1078       if Verbose_Mode and (not File_Deleted) then
1079          New_Line;
1080
1081          if Do_Nothing then
1082             Put_Line ("No file needs to be deleted");
1083          else
1084             Put_Line ("No file has been deleted");
1085          end if;
1086       end if;
1087    end Gnatclean;
1088
1089    ------------------------
1090    -- In_Extension_Chain --
1091    ------------------------
1092
1093    function In_Extension_Chain
1094      (Of_Project : Project_Id;
1095       Prj        : Project_Id) return Boolean
1096    is
1097       Data : Project_Data;
1098
1099    begin
1100       if Of_Project = Prj then
1101          return True;
1102       end if;
1103
1104       Data := Projects.Table (Of_Project);
1105
1106       while Data.Extends /= No_Project loop
1107          if Data.Extends = Prj then
1108             return True;
1109          end if;
1110
1111          Data := Projects.Table (Data.Extends);
1112       end loop;
1113
1114       Data := Projects.Table (Prj);
1115
1116       while Data.Extends /= No_Project loop
1117          if Data.Extends = Of_Project then
1118             return True;
1119          end if;
1120
1121          Data := Projects.Table (Data.Extends);
1122       end loop;
1123
1124       return False;
1125    end In_Extension_Chain;
1126
1127    ------------
1128    -- Init_Q --
1129    ------------
1130
1131    procedure Init_Q is
1132    begin
1133       Q_Front := Q.First;
1134       Q.Set_Last (Q.First);
1135    end Init_Q;
1136
1137    ----------------
1138    -- Initialize --
1139    ----------------
1140
1141    procedure Initialize is
1142    begin
1143       if not Initialized then
1144          Initialized := True;
1145
1146          --  Initialize some packages
1147
1148          Csets.Initialize;
1149          Namet.Initialize;
1150          Snames.Initialize;
1151          Prj.Initialize;
1152       end if;
1153
1154       --  Reset global variables
1155
1156       Free (Object_Directory_Path);
1157       Do_Nothing := False;
1158       File_Deleted := False;
1159       Copyright_Displayed := False;
1160       Usage_Displayed := False;
1161       Free (Project_File_Name);
1162       Main_Project := Prj.No_Project;
1163       All_Projects := False;
1164    end Initialize;
1165
1166    --------------
1167    -- Insert_Q --
1168    --------------
1169
1170    procedure Insert_Q (Lib_File : File_Name_Type) is
1171    begin
1172       --  Do not insert an empty name or an already marked source
1173
1174       if Lib_File /= No_Name and then not Is_Marked (Lib_File) then
1175          Q.Table (Q.Last) := Lib_File;
1176          Q.Increment_Last;
1177
1178          --  Mark the source that has been just added to the Q
1179
1180          Mark (Lib_File);
1181       end if;
1182    end Insert_Q;
1183
1184    ----------------------
1185    -- Object_File_Name --
1186    ----------------------
1187
1188    function Object_File_Name (Source : Name_Id) return String is
1189       Src : constant String := Get_Name_String (Source);
1190
1191    begin
1192       --  If the source name has an extension, then replace it with
1193       --  the Object suffix.
1194
1195       for Index in reverse Src'First + 1 .. Src'Last loop
1196          if Src (Index) = '.' then
1197             return Src (Src'First .. Index - 1) & Object_Suffix;
1198          end if;
1199       end loop;
1200
1201       --  If there is no dot, or if it is the first character, just add the
1202       --  ALI suffix.
1203
1204       return Src & Object_Suffix;
1205    end Object_File_Name;
1206
1207    --------------------
1208    -- Parse_Cmd_Line --
1209    --------------------
1210
1211    procedure Parse_Cmd_Line is
1212       Source_Index : Int := 0;
1213       Index : Positive := 1;
1214       Last  : constant Natural := Argument_Count;
1215    begin
1216       while Index <= Last loop
1217          declare
1218             Arg : constant String := Argument (Index);
1219
1220             procedure Bad_Argument;
1221             --  Signal bad argument
1222
1223             ------------------
1224             -- Bad_Argument --
1225             ------------------
1226
1227             procedure Bad_Argument is
1228             begin
1229                Fail ("invalid argument """, Arg, """");
1230             end Bad_Argument;
1231
1232          begin
1233             if Arg'Length /= 0 then
1234                if Arg (1) = '-' then
1235                   if Arg'Length = 1 then
1236                      Bad_Argument;
1237                   end if;
1238
1239                   case Arg (2) is
1240                      when 'a' =>
1241                         if Arg'Length < 4 or else Arg (3) /= 'O' then
1242                            Bad_Argument;
1243                         end if;
1244
1245                         Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
1246
1247                      when 'c'    =>
1248                         Compile_Only := True;
1249
1250                      when 'D'    =>
1251                         if Object_Directory_Path /= null then
1252                            Fail ("duplicate -D switch");
1253
1254                         elsif Project_File_Name /= null then
1255                            Fail ("-P and -D cannot be used simultaneously");
1256                         end if;
1257
1258                         if Arg'Length > 2 then
1259                            declare
1260                               Dir : constant String := Arg (3 .. Arg'Last);
1261                            begin
1262                               if not Is_Directory (Dir) then
1263                                  Fail (Dir, " is not a directory");
1264                               else
1265                                  Add_Lib_Search_Dir (Dir);
1266                               end if;
1267                            end;
1268
1269                         else
1270                            if Index = Last then
1271                               Fail ("no directory specified after -D");
1272                            end if;
1273
1274                            Index := Index + 1;
1275
1276                            declare
1277                               Dir : constant String := Argument (Index);
1278                            begin
1279                               if not Is_Directory (Dir) then
1280                                  Fail (Dir, " is not a directory");
1281                               else
1282                                  Add_Lib_Search_Dir (Dir);
1283                               end if;
1284                            end;
1285                         end if;
1286
1287                      when 'F' =>
1288                         Full_Path_Name_For_Brief_Errors := True;
1289
1290                      when 'h' =>
1291                         Usage;
1292
1293                      when 'i' =>
1294                         if Arg'Length = 2 then
1295                            Bad_Argument;
1296                         end if;
1297
1298                         Source_Index := 0;
1299
1300                         for J in 3 .. Arg'Last loop
1301                            if Arg (J) not in '0' .. '9' then
1302                               Bad_Argument;
1303                            end if;
1304
1305                            Source_Index :=
1306                              (20 * Source_Index) +
1307                              (Character'Pos (Arg (J)) - Character'Pos ('0'));
1308                         end loop;
1309
1310                      when 'I' =>
1311                         if Arg = "-I-" then
1312                            Opt.Look_In_Primary_Dir := False;
1313
1314                         else
1315                            if Arg'Length = 2 then
1316                               Bad_Argument;
1317                            end if;
1318
1319                            Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
1320                         end if;
1321
1322                      when 'n' =>
1323                         Do_Nothing := True;
1324
1325                      when 'P' =>
1326                         if Project_File_Name /= null then
1327                            Fail ("multiple -P switches");
1328
1329                         elsif Object_Directory_Path /= null then
1330                            Fail ("-D and -P cannot be used simultaneously");
1331
1332                         end if;
1333
1334                         if Arg'Length > 2 then
1335                            declare
1336                               Prj : constant String := Arg (3 .. Arg'Last);
1337                            begin
1338                               if Prj'Length > 1 and then
1339                                 Prj (Prj'First) = '='
1340                               then
1341                                  Project_File_Name :=
1342                                    new String'
1343                                      (Prj (Prj'First + 1 ..  Prj'Last));
1344                               else
1345                                  Project_File_Name := new String'(Prj);
1346                               end if;
1347                            end;
1348
1349                         else
1350                            if Index = Last then
1351                               Fail ("no project specified after -P");
1352                            end if;
1353
1354                            Index := Index + 1;
1355                            Project_File_Name := new String'(Argument (Index));
1356                         end if;
1357
1358                      when 'q' =>
1359                         Quiet_Output := True;
1360
1361                      when 'r' =>
1362                         All_Projects := True;
1363
1364                      when 'v' =>
1365                         if Arg = "-v" then
1366                            Verbose_Mode := True;
1367
1368                         elsif Arg = "-vP0" then
1369                            Prj.Com.Current_Verbosity := Prj.Default;
1370
1371                         elsif Arg = "-vP1" then
1372                            Prj.Com.Current_Verbosity := Prj.Medium;
1373
1374                         elsif Arg = "-vP2" then
1375                            Prj.Com.Current_Verbosity := Prj.High;
1376
1377                         else
1378                            Bad_Argument;
1379                         end if;
1380
1381                      when 'X' =>
1382                         if Arg'Length = 2 then
1383                            Bad_Argument;
1384                         end if;
1385
1386                         declare
1387                            Ext_Asgn  : constant String := Arg (3 .. Arg'Last);
1388                            Start     : Positive := Ext_Asgn'First;
1389                            Stop      : Natural  := Ext_Asgn'Last;
1390                            Equal_Pos : Natural;
1391                            OK        : Boolean  := True;
1392
1393                         begin
1394                            if Ext_Asgn (Start) = '"' then
1395                               if Ext_Asgn (Stop) = '"' then
1396                                  Start := Start + 1;
1397                                  Stop  := Stop - 1;
1398
1399                               else
1400                                  OK := False;
1401                               end if;
1402                            end if;
1403
1404                            Equal_Pos := Start;
1405
1406                            while Equal_Pos <= Stop
1407                              and then Ext_Asgn (Equal_Pos) /= '='
1408                            loop
1409                               Equal_Pos := Equal_Pos + 1;
1410                            end loop;
1411
1412                            if Equal_Pos = Start or else Equal_Pos > Stop then
1413                               OK := False;
1414                            end if;
1415
1416                            if OK then
1417                               Prj.Ext.Add
1418                                 (External_Name =>
1419                                    Ext_Asgn (Start .. Equal_Pos - 1),
1420                                  Value         =>
1421                                    Ext_Asgn (Equal_Pos + 1 .. Stop));
1422
1423                            else
1424                               Fail
1425                                 ("illegal external assignment '",
1426                                  Ext_Asgn, "'");
1427                            end if;
1428                         end;
1429
1430                      when others =>
1431                         Bad_Argument;
1432                   end case;
1433
1434                else
1435                   Add_File (Arg, Source_Index);
1436                end if;
1437             end if;
1438          end;
1439
1440          Index := Index + 1;
1441       end loop;
1442    end Parse_Cmd_Line;
1443
1444    -----------------------
1445    -- Repinfo_File_Name --
1446    -----------------------
1447
1448    function Repinfo_File_Name (Source : Name_Id) return String is
1449    begin
1450       return Get_Name_String (Source) & Repinfo_Suffix;
1451    end Repinfo_File_Name;
1452
1453    --------------------
1454    -- Tree_File_Name --
1455    --------------------
1456
1457    function Tree_File_Name (Source : Name_Id) return String is
1458       Src : constant String := Get_Name_String (Source);
1459
1460    begin
1461       --  If the source name has an extension, then replace it with
1462       --  the tree suffix.
1463
1464       for Index in reverse Src'First + 1 .. Src'Last loop
1465          if Src (Index) = '.' then
1466             return Src (Src'First .. Index - 1) & Tree_Suffix;
1467          end if;
1468       end loop;
1469
1470       --  If there is no dot, or if it is the first character, just add the
1471       --  tree suffix.
1472
1473       return Src & Tree_Suffix;
1474    end Tree_File_Name;
1475
1476    -----------
1477    -- Usage --
1478    -----------
1479
1480    procedure Usage is
1481    begin
1482       if not Usage_Displayed then
1483          Usage_Displayed := True;
1484          Display_Copyright;
1485          Put_Line ("Usage: gnatclean [switches] {[-innn] name}");
1486          New_Line;
1487
1488          Put_Line ("  names is one or more file names from which " &
1489                    "the .adb or .ads suffix may be omitted");
1490          Put_Line ("  names may be omitted if -P<project> is specified");
1491          New_Line;
1492
1493          Put_Line ("  -c       Only delete compiler generated files");
1494          Put_Line ("  -D dir   Specify dir as the object library");
1495          Put_Line ("  -F       Full project path name " &
1496                    "in brief error messages");
1497          Put_Line ("  -h       Display this message");
1498          Put_Line ("  -innn    Index of unit in source for following names");
1499          Put_Line ("  -n       Nothing to do: only list files to delete");
1500          Put_Line ("  -Pproj   Use GNAT Project File proj");
1501          Put_Line ("  -q       Be quiet/terse");
1502          Put_Line ("  -r       Clean all projects recursively");
1503          Put_Line ("  -v       Verbose mode");
1504          Put_Line ("  -vPx     Specify verbosity when parsing " &
1505                    "GNAT Project Files");
1506          Put_Line ("  -Xnm=val Specify an external reference " &
1507                    "for GNAT Project Files");
1508          New_Line;
1509
1510          Put_Line ("  -aOdir   Specify ALI/object files search path");
1511          Put_Line ("  -Idir    Like -aOdir");
1512          Put_Line ("  -I-      Don't look for source/library files " &
1513                    "in the default directory");
1514          New_Line;
1515       end if;
1516    end Usage;
1517
1518 begin
1519    if Hostparm.OpenVMS then
1520       Debug_Suffix (Debug_Suffix'First) := '_';
1521       Repinfo_Suffix (Repinfo_Suffix'First) := '_';
1522       B_Start (B_Start'Last) := '$';
1523    end if;
1524 end Clean;