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