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-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with ALI;       use ALI;
  27 with Make_Util; use Make_Util;
  28 with Namet;     use Namet;
  29 with Opt;       use Opt;
  30 with Osint;     use Osint;
  31 with Osint.M;   use Osint.M;
  32 with Switch;    use Switch;
  33 with Table;
  34 with Targparm;
  35 with Types;     use Types;
  36
  37 with Ada.Command_Line;          use Ada.Command_Line;
  38
  39 with GNAT.Command_Line;         use GNAT.Command_Line;
  40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  41 with GNAT.IO;                   use GNAT.IO;
  42 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  43
  44 package body Clean is
  45
  46    --  Suffixes of various files
  47
  48    Assembly_Suffix : constant String := ".s";
  49    Tree_Suffix     : constant String := ".adt";
  50    Object_Suffix   : constant String := Get_Target_Object_Suffix.all;
  51    Debug_Suffix    : constant String := ".dg";
  52    Repinfo_Suffix  : constant String := ".rep";
  53    --  Suffix of representation info files
  54
  55    B_Start : constant String := "b~";
  56    --  Prefix of binder generated file, and number of actual characters used
  57
  58    Object_Directory_Path : String_Access := null;
  59    --  The path name of the object directory, set with switch -D
  60
  61    Force_Deletions : Boolean := False;
  62    --  Set to True by switch -f. When True, attempts to delete non writable
  63    --  files will be done.
  64
  65    Do_Nothing : Boolean := False;
  66    --  Set to True when switch -n is specified. When True, no file is deleted.
  67    --  gnatclean only lists the files that would have been deleted if the
  68    --  switch -n had not been specified.
  69
  70    File_Deleted : Boolean := False;
  71    --  Set to True if at least one file has been deleted
  72
  73    Copyright_Displayed : Boolean := False;
  74    Usage_Displayed     : Boolean := False;
  75
  76    Project_File_Name : String_Access := null;
  77
  78    package Sources is new Table.Table
  79      (Table_Component_Type => File_Name_Type,
  80       Table_Index_Type     => Natural,
  81       Table_Low_Bound      => 0,
  82       Table_Initial        => 10,
  83       Table_Increment      => 100,
  84       Table_Name           => "Clean.Processed_Projects");
  85    --  Table to store all the source files of a library unit: spec, body and
  86    --  subunits, to detect .dg files and delete them.
  87
  88    -----------------------------
  89    -- Other local subprograms --
  90    -----------------------------
  91
  92    function Assembly_File_Name (Source : File_Name_Type) return String;
  93    --  Returns the assembly file name corresponding to Source
  94
  95    procedure Clean_Executables;
  96    --  Do the cleaning work when no project file is specified
  97
  98    function Debug_File_Name (Source : File_Name_Type) return String;
  99    --  Name of the expanded source file corresponding to Source
 100
 101    procedure Delete (In_Directory : String; File : String);
 102    --  Delete one file, or list the file name if switch -n is specified
 103
 104    procedure Delete_Binder_Generated_Files
 105      (Dir    : String;
 106       Source : File_Name_Type);
 107    --  Delete the binder generated file in directory Dir for Source, if they
 108    --  exist: for Unix these are b~<source>.ads, b~<source>.adb,
 109    --  b~<source>.ali and b~<source>.o.
 110
 111    procedure Display_Copyright;
 112    --  Display the Copyright notice. If called several times, display the
 113    --  Copyright notice only the first time.
 114
 115    procedure Initialize;
 116    --  Call the necessary package initializations
 117
 118    function Object_File_Name (Source : File_Name_Type) return String;
 119    --  Returns the object file name corresponding to Source
 120
 121    procedure Parse_Cmd_Line;
 122    --  Parse the command line
 123
 124    function Repinfo_File_Name (Source : File_Name_Type) return String;
 125    --  Returns the repinfo file name corresponding to Source
 126
 127    function Tree_File_Name (Source : File_Name_Type) return String;
 128    --  Returns the tree file name corresponding to Source
 129
 130    procedure Usage;
 131    --  Display the usage. If called several times, the usage is displayed only
 132    --  the first time.
 133
 134    ------------------------
 135    -- Assembly_File_Name --
 136    ------------------------
 137
 138    function Assembly_File_Name (Source : File_Name_Type) return String is
 139       Src : constant String := Get_Name_String (Source);
 140
 141    begin
 142       --  If the source name has an extension, then replace it with
 143       --  the assembly suffix.
 144
 145       for Index in reverse Src'First + 1 .. Src'Last loop
 146          if Src (Index) = '.' then
 147             return Src (Src'First .. Index - 1) & Assembly_Suffix;
 148          end if;
 149       end loop;
 150
 151       --  If there is no dot, or if it is the first character, just add the
 152       --  assembly suffix.
 153
 154       return Src & Assembly_Suffix;
 155    end Assembly_File_Name;
 156
 157    -----------------------
 158    -- Clean_Executables --
 159    -----------------------
 160
 161    procedure Clean_Executables is
 162       Main_Source_File : File_Name_Type;
 163       --  Current main source
 164
 165       Main_Lib_File : File_Name_Type;
 166       --  ALI file of the current main
 167
 168       Lib_File : File_Name_Type;
 169       --  Current ALI file
 170
 171       Full_Lib_File : File_Name_Type;
 172       --  Full name of the current ALI file
 173
 174       Text    : Text_Buffer_Ptr;
 175       The_ALI : ALI_Id;
 176       Found   : Boolean;
 177       Source  : Queue.Source_Info;
 178
 179    begin
 180       Queue.Initialize;
 181
 182       --  It does not really matter if there is or not an object file
 183       --  corresponding to an ALI file: if there is one, it will be deleted.
 184
 185       Opt.Check_Object_Consistency := False;
 186
 187       --  Proceed each executable one by one. Each source is marked as it is
 188       --  processed, so common sources between executables will not be
 189       --  processed several times.
 190
 191       for N_File in 1 .. Osint.Number_Of_Files loop
 192          Main_Source_File := Next_Main_Source;
 193          Main_Lib_File :=
 194            Osint.Lib_File_Name (Main_Source_File, Current_File_Index);
 195
 196          if Main_Lib_File /= No_File then
 197             Queue.Insert
 198               ((File    => Main_Lib_File,
 199                 Unit    => No_Unit_Name,
 200                 Index   => 0));
 201          end if;
 202
 203          while not Queue.Is_Empty loop
 204             Sources.Set_Last (0);
 205             Queue.Extract (Found, Source);
 206             pragma Assert (Found);
 207             pragma Assert (Source.File /= No_File);
 208             Lib_File := Source.File;
 209             Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
 210
 211             --  If we have existing ALI file that is not read-only, process it
 212
 213             if Full_Lib_File /= No_File
 214               and then not Is_Readonly_Library (Full_Lib_File)
 215             then
 216                Text := Read_Library_Info (Lib_File);
 217
 218                if Text /= null then
 219                   The_ALI :=
 220                     Scan_ALI (Lib_File, Text, Err => True);
 221                   Free (Text);
 222
 223                   --  If no error was produced while loading this ALI file,
 224                   --  insert into the queue all the unmarked withed sources.
 225
 226                   if The_ALI /= No_ALI_Id then
 227                      for J in ALIs.Table (The_ALI).First_Unit ..
 228                        ALIs.Table (The_ALI).Last_Unit
 229                      loop
 230                         Sources.Increment_Last;
 231                         Sources.Table (Sources.Last) :=
 232                           ALI.Units.Table (J).Sfile;
 233
 234                         for K in ALI.Units.Table (J).First_With ..
 235                           ALI.Units.Table (J).Last_With
 236                         loop
 237                            if Withs.Table (K).Afile /= No_File then
 238                               Queue.Insert
 239                                 ((File    => Withs.Table (K).Afile,
 240                                   Unit    => No_Unit_Name,
 241                                   Index   => 0));
 242                            end if;
 243                         end loop;
 244                      end loop;
 245
 246                      --  Look for subunits and put them in the Sources table
 247
 248                      for J in ALIs.Table (The_ALI).First_Sdep ..
 249                        ALIs.Table (The_ALI).Last_Sdep
 250                      loop
 251                         if Sdep.Table (J).Subunit_Name /= No_Name then
 252                            Sources.Increment_Last;
 253                            Sources.Table (Sources.Last) :=
 254                              Sdep.Table (J).Sfile;
 255                         end if;
 256                      end loop;
 257                   end if;
 258                end if;
 259
 260                --  Now delete all existing files corresponding to this ALI file
 261
 262                declare
 263                   Obj_Dir : constant String :=
 264                     Dir_Name (Get_Name_String (Full_Lib_File));
 265                   Obj     : constant String := Object_File_Name (Lib_File);
 266                   Adt     : constant String := Tree_File_Name   (Lib_File);
 267                   Asm     : constant String := Assembly_File_Name (Lib_File);
 268
 269                begin
 270                   Delete (Obj_Dir, Get_Name_String (Lib_File));
 271
 272                   if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then
 273                      Delete (Obj_Dir, Obj);
 274                   end if;
 275
 276                   if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then
 277                      Delete (Obj_Dir, Adt);
 278                   end if;
 279
 280                   if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then
 281                      Delete (Obj_Dir, Asm);
 282                   end if;
 283
 284                   --  Delete expanded source files (.dg) and/or repinfo files
 285                   --  (.rep) if any
 286
 287                   for J in 1 .. Sources.Last loop
 288                      declare
 289                         Deb : constant String :=
 290                           Debug_File_Name (Sources.Table (J));
 291                         Rep : constant String :=
 292                           Repinfo_File_Name (Sources.Table (J));
 293
 294                      begin
 295                         if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
 296                            Delete (Obj_Dir, Deb);
 297                         end if;
 298
 299                         if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then
 300                            Delete (Obj_Dir, Rep);
 301                         end if;
 302                      end;
 303                   end loop;
 304                end;
 305             end if;
 306          end loop;
 307
 308          --  Delete the executable, if it exists, and the binder generated
 309          --  files, if any.
 310
 311          if not Compile_Only then
 312             declare
 313                Source     : constant File_Name_Type :=
 314                  Strip_Suffix (Main_Lib_File);
 315                Executable : constant String :=
 316                  Get_Name_String (Executable_Name (Source));
 317             begin
 318                if Is_Regular_File (Executable) then
 319                   Delete ("", Executable);
 320                end if;
 321
 322                Delete_Binder_Generated_Files (Get_Current_Dir, Source);
 323             end;
 324          end if;
 325       end loop;
 326    end Clean_Executables;
 327
 328    ---------------------
 329    -- Debug_File_Name --
 330    ---------------------
 331
 332    function Debug_File_Name (Source : File_Name_Type) return String is
 333    begin
 334       return Get_Name_String (Source) & Debug_Suffix;
 335    end Debug_File_Name;
 336
 337    ------------
 338    -- Delete --
 339    ------------
 340
 341    procedure Delete (In_Directory : String; File : String) is
 342       Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
 343       Last      : Natural := 0;
 344       Success   : Boolean;
 345
 346    begin
 347       --  Indicate that at least one file is deleted or is to be deleted
 348
 349       File_Deleted := True;
 350
 351       --  Build the path name of the file to delete
 352
 353       Last := In_Directory'Length;
 354       Full_Name (1 .. Last) := In_Directory;
 355
 356       if Last > 0 and then Full_Name (Last) /= Directory_Separator then
 357          Last := Last + 1;
 358          Full_Name (Last) := Directory_Separator;
 359       end if;
 360
 361       Full_Name (Last + 1 .. Last + File'Length) := File;
 362       Last := Last + File'Length;
 363
 364       --  If switch -n was used, simply output the path name
 365
 366       if Do_Nothing then
 367          Put_Line (Full_Name (1 .. Last));
 368
 369       --  Otherwise, delete the file if it is writable
 370
 371       else
 372          if Force_Deletions
 373            or else Is_Writable_File (Full_Name (1 .. Last))
 374            or else Is_Symbolic_Link (Full_Name (1 .. Last))
 375          then
 376             Delete_File (Full_Name (1 .. Last), Success);
 377
 378          --  Here if no deletion required
 379
 380          else
 381             Success := False;
 382          end if;
 383
 384          if Verbose_Mode or else not Quiet_Output then
 385             if not Success then
 386                Put ("Warning: """);
 387                Put (Full_Name (1 .. Last));
 388                Put_Line (""" could not be deleted");
 389
 390             else
 391                Put ("""");
 392                Put (Full_Name (1 .. Last));
 393                Put_Line (""" has been deleted");
 394             end if;
 395          end if;
 396       end if;
 397    end Delete;
 398
 399    -----------------------------------
 400    -- Delete_Binder_Generated_Files --
 401    -----------------------------------
 402
 403    procedure Delete_Binder_Generated_Files
 404      (Dir    : String;
 405       Source : File_Name_Type)
 406    is
 407       Source_Name : constant String   := Get_Name_String (Source);
 408       Current     : constant String   := Get_Current_Dir;
 409       Last        : constant Positive := B_Start'Length + Source_Name'Length;
 410       File_Name   : String (1 .. Last + 4);
 411
 412    begin
 413       Change_Dir (Dir);
 414
 415       --  Build the file name (before the extension)
 416
 417       File_Name (1 .. B_Start'Length) := B_Start;
 418       File_Name (B_Start'Length + 1 .. Last) := Source_Name;
 419
 420       --  Spec
 421
 422       File_Name (Last + 1 .. Last + 4) := ".ads";
 423
 424       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 425          Delete (Dir, File_Name (1 .. Last + 4));
 426       end if;
 427
 428       --  Body
 429
 430       File_Name (Last + 1 .. Last + 4) := ".adb";
 431
 432       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 433          Delete (Dir, File_Name (1 .. Last + 4));
 434       end if;
 435
 436       --  ALI file
 437
 438       File_Name (Last + 1 .. Last + 4) := ".ali";
 439
 440       if Is_Regular_File (File_Name (1 .. Last + 4)) then
 441          Delete (Dir, File_Name (1 .. Last + 4));
 442       end if;
 443
 444       --  Object file
 445
 446       File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix;
 447
 448       if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then
 449          Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length));
 450       end if;
 451
 452       --  Change back to previous directory
 453
 454       Change_Dir (Current);
 455    end Delete_Binder_Generated_Files;
 456
 457    -----------------------
 458    -- Display_Copyright --
 459    -----------------------
 460
 461    procedure Display_Copyright is
 462    begin
 463       if not Copyright_Displayed then
 464          Copyright_Displayed := True;
 465          Display_Version ("GNATCLEAN", "2003");
 466       end if;
 467    end Display_Copyright;
 468
 469    ---------------
 470    -- Gnatclean --
 471    ---------------
 472
 473    procedure Gnatclean is
 474    begin
 475       --  Do the necessary initializations
 476
 477       Clean.Initialize;
 478
 479       --  Parse the command line, getting the switches and the executable names
 480
 481       Parse_Cmd_Line;
 482
 483       if Verbose_Mode then
 484          Display_Copyright;
 485       end if;
 486
 487       Osint.Add_Default_Search_Dirs;
 488       Targparm.Get_Target_Parameters;
 489
 490       if Osint.Number_Of_Files = 0 then
 491          if Argument_Count = 0 then
 492             Usage;
 493          else
 494             Try_Help;
 495          end if;
 496
 497          return;
 498       end if;
 499
 500       if Verbose_Mode then
 501          New_Line;
 502       end if;
 503
 504       if Project_File_Name /= null then
 505          declare
 506             Gprclean_Path : constant String_Access :=
 507               Locate_Exec_On_Path ("gprclean");
 508             Arg_Len : Natural       := Argument_Count;
 509             Pos     : Natural       := 0;
 510             Target  : String_Access := null;
 511             Success : Boolean       := False;
 512          begin
 513             if Gprclean_Path = null then
 514                Fail_Program
 515                  ("project files are no longer supported by gnatclean;" &
 516                     " use gprclean instead");
 517             end if;
 518
 519             Find_Program_Name;
 520
 521             if Name_Len > 10
 522               and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
 523             then
 524                Target  := new String'(Name_Buffer (1 .. Name_Len - 9));
 525                Arg_Len := Arg_Len + 1;
 526             end if;
 527
 528             declare
 529                Args : Argument_List (1 .. Arg_Len);
 530             begin
 531                if Target /= null then
 532                   Args (1) := new String'("--target=" & Target.all);
 533                   Pos := 1;
 534                end if;
 535
 536                for J in 1 .. Argument_Count loop
 537                   Pos := Pos + 1;
 538                   Args (Pos) := new String'(Argument (J));
 539                end loop;
 540
 541                Spawn (Gprclean_Path.all, Args, Success);
 542
 543                if Success then
 544                   Exit_Program (E_Success);
 545                else
 546                   Exit_Program (E_Errors);
 547                end if;
 548             end;
 549          end;
 550       end if;
 551
 552       Clean_Executables;
 553
 554       --  In verbose mode, if Delete has not been called, indicate that no file
 555       --  needs to be deleted.
 556
 557       if Verbose_Mode and not File_Deleted then
 558          New_Line;
 559
 560          if Do_Nothing then
 561             Put_Line ("No file needs to be deleted");
 562          else
 563             Put_Line ("No file has been deleted");
 564          end if;
 565       end if;
 566    end Gnatclean;
 567
 568    ----------------
 569    -- Initialize --
 570    ----------------
 571
 572    procedure Initialize is
 573    begin
 574       --  Reset global variables
 575
 576       Free (Object_Directory_Path);
 577       Do_Nothing := False;
 578       File_Deleted := False;
 579       Copyright_Displayed := False;
 580       Usage_Displayed := False;
 581    end Initialize;
 582
 583    ----------------------
 584    -- Object_File_Name --
 585    ----------------------
 586
 587    function Object_File_Name (Source : File_Name_Type) return String is
 588       Src : constant String := Get_Name_String (Source);
 589
 590    begin
 591       --  If the source name has an extension, then replace it with
 592       --  the Object suffix.
 593
 594       for Index in reverse Src'First + 1 .. Src'Last loop
 595          if Src (Index) = '.' then
 596             return Src (Src'First .. Index - 1) & Object_Suffix;
 597          end if;
 598       end loop;
 599
 600       --  If there is no dot, or if it is the first character, just add the
 601       --  ALI suffix.
 602
 603       return Src & Object_Suffix;
 604    end Object_File_Name;
 605
 606    --------------------
 607    -- Parse_Cmd_Line --
 608    --------------------
 609
 610    procedure Parse_Cmd_Line is
 611       Last         : constant Natural := Argument_Count;
 612       Index        : Positive;
 613       Source_Index : Int := 0;
 614
 615       procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
 616
 617    begin
 618       --  First, check for --version and --help
 619
 620       Check_Version_And_Help ("GNATCLEAN", "2003");
 621
 622       --  First, check for switch -P and, if found and gprclean is available,
 623       --  silently invoke gprclean, with switch --target if not on a native
 624       --  platform.
 625
 626       declare
 627          Arg_Len       : Positive      := Argument_Count;
 628          Call_Gprclean : Boolean       := False;
 629          Gprclean      : String_Access := null;
 630          Pos           : Natural       := 0;
 631          Success       : Boolean;
 632          Target        : String_Access := null;
 633
 634       begin
 635          Find_Program_Name;
 636
 637          if Name_Len >= 9
 638            and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
 639          then
 640             if Name_Len > 9 then
 641                Target  := new String'(Name_Buffer (1 .. Name_Len - 10));
 642                Arg_Len := Arg_Len + 1;
 643             end if;
 644
 645             for J in 1 .. Argument_Count loop
 646                declare
 647                   Arg : constant String := Argument (J);
 648                begin
 649                   if Arg'Length >= 2
 650                     and then Arg (Arg'First .. Arg'First + 1) = "-P"
 651                   then
 652                      Call_Gprclean := True;
 653                      exit;
 654                   end if;
 655                end;
 656             end loop;
 657
 658             if Call_Gprclean then
 659                Gprclean := Locate_Exec_On_Path (Exec_Name => "gprclean");
 660
 661                if Gprclean /= null then
 662                   declare
 663                      Args : Argument_List (1 .. Arg_Len);
 664                   begin
 665                      if Target /= null then
 666                         Args (1) := new String'("--target=" & Target.all);
 667                         Pos := 1;
 668                      end if;
 669
 670                      for J in 1 .. Argument_Count loop
 671                         Pos := Pos + 1;
 672                         Args (Pos) := new String'(Argument (J));
 673                      end loop;
 674
 675                      Spawn (Gprclean.all, Args, Success);
 676
 677                      Free (Gprclean);
 678
 679                      if Success then
 680                         Exit_Program (E_Success);
 681
 682                      else
 683                         Exit_Program (E_Fatal);
 684                      end if;
 685                   end;
 686                end if;
 687             end if;
 688          end if;
 689       end;
 690
 691       Index := 1;
 692       while Index <= Last loop
 693          declare
 694             Arg : constant String := Argument (Index);
 695
 696             procedure Bad_Argument;
 697             pragma No_Return (Bad_Argument);
 698             --  Signal bad argument
 699
 700             ------------------
 701             -- Bad_Argument --
 702             ------------------
 703
 704             procedure Bad_Argument is
 705             begin
 706                Fail ("invalid argument """ & Arg & """");
 707             end Bad_Argument;
 708
 709          begin
 710             if Arg'Length /= 0 then
 711                if Arg (1) = '-' then
 712                   if Arg'Length = 1 then
 713                      Bad_Argument;
 714                   end if;
 715
 716                   case Arg (2) is
 717                      when '-' =>
 718                         if Arg'Length > Subdirs_Option'Length
 719                           and then
 720                             Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
 721                         then
 722                            null;
 723                            --  Subdirs are only used in gprclean
 724
 725                         elsif Arg = Make_Util.Unchecked_Shared_Lib_Imports then
 726                            Opt.Unchecked_Shared_Lib_Imports := True;
 727
 728                         else
 729                            Bad_Argument;
 730                         end if;
 731
 732                      when 'a' =>
 733                         if Arg'Length < 4 then
 734                            Bad_Argument;
 735                         end if;
 736
 737                         if Arg (3) = 'O' then
 738                            Add_Lib_Search_Dir (Arg (4 .. Arg'Last));
 739
 740                         elsif Arg (3) = 'P' then
 741                            null;
 742                            --  This is only for gprclean
 743
 744                         else
 745                            Bad_Argument;
 746                         end if;
 747
 748                      when 'c' =>
 749                         Compile_Only := True;
 750
 751                      when 'D' =>
 752                         if Object_Directory_Path /= null then
 753                            Fail ("duplicate -D switch");
 754
 755                         elsif Project_File_Name /= null then
 756                            Fail ("-P and -D cannot be used simultaneously");
 757                         end if;
 758
 759                         if Arg'Length > 2 then
 760                            declare
 761                               Dir : constant String := Arg (3 .. Arg'Last);
 762                            begin
 763                               if not Is_Directory (Dir) then
 764                                  Fail (Dir & " is not a directory");
 765                               else
 766                                  Add_Lib_Search_Dir (Dir);
 767                               end if;
 768                            end;
 769
 770                         else
 771                            if Index = Last then
 772                               Fail ("no directory specified after -D");
 773                            end if;
 774
 775                            Index := Index + 1;
 776
 777                            declare
 778                               Dir : constant String := Argument (Index);
 779                            begin
 780                               if not Is_Directory (Dir) then
 781                                  Fail (Dir & " is not a directory");
 782                               else
 783                                  Add_Lib_Search_Dir (Dir);
 784                               end if;
 785                            end;
 786                         end if;
 787
 788                      when 'e' =>
 789                         if Arg = "-eL" then
 790                            Follow_Links_For_Files := True;
 791                            Follow_Links_For_Dirs  := True;
 792
 793                         else
 794                            Bad_Argument;
 795                         end if;
 796
 797                      when 'f' =>
 798                         Force_Deletions := True;
 799                         Directories_Must_Exist_In_Projects := False;
 800
 801                      when 'F' =>
 802                         Full_Path_Name_For_Brief_Errors := True;
 803
 804                      when 'h' =>
 805                         Usage;
 806
 807                      when 'i' =>
 808                         if Arg'Length = 2 then
 809                            Bad_Argument;
 810                         end if;
 811
 812                         Source_Index := 0;
 813
 814                         for J in 3 .. Arg'Last loop
 815                            if Arg (J) not in '0' .. '9' then
 816                               Bad_Argument;
 817                            end if;
 818
 819                            Source_Index :=
 820                              (20 * Source_Index) +
 821                              (Character'Pos (Arg (J)) - Character'Pos ('0'));
 822                         end loop;
 823
 824                      when 'I' =>
 825                         if Arg = "-I-" then
 826                            Opt.Look_In_Primary_Dir := False;
 827
 828                         else
 829                            if Arg'Length = 2 then
 830                               Bad_Argument;
 831                            end if;
 832
 833                            Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
 834                         end if;
 835
 836                      when 'n' =>
 837                         Do_Nothing := True;
 838
 839                      when 'P' =>
 840                         if Project_File_Name /= null then
 841                            Fail ("multiple -P switches");
 842
 843                         elsif Object_Directory_Path /= null then
 844                            Fail ("-D and -P cannot be used simultaneously");
 845
 846                         end if;
 847
 848                         if Arg'Length > 2 then
 849                            declare
 850                               Prj : constant String := Arg (3 .. Arg'Last);
 851                            begin
 852                               if Prj'Length > 1
 853                                  and then Prj (Prj'First) = '='
 854                               then
 855                                  Project_File_Name :=
 856                                    new String'
 857                                      (Prj (Prj'First + 1 .. Prj'Last));
 858                               else
 859                                  Project_File_Name := new String'(Prj);
 860                               end if;
 861                            end;
 862
 863                         else
 864                            if Index = Last then
 865                               Fail ("no project specified after -P");
 866                            end if;
 867
 868                            Index := Index + 1;
 869                            Project_File_Name := new String'(Argument (Index));
 870                         end if;
 871
 872                      when 'q' =>
 873                         Quiet_Output := True;
 874
 875                      when 'r' =>
 876                         null;
 877                         --  This is only for gprclean
 878
 879                      when 'v' =>
 880                         if Arg = "-v" then
 881                            Verbose_Mode := True;
 882
 883                         elsif Arg = "-vP0"
 884                           or else Arg = "-vP1"
 885                           or else Arg = "-vP2"
 886                         then
 887                            null;
 888                            --  This is only for gprclean
 889
 890                         else
 891                            Bad_Argument;
 892                         end if;
 893
 894                      when 'X' =>
 895                         if Arg'Length = 2 then
 896                            Bad_Argument;
 897                         end if;
 898
 899                      when others =>
 900                         Bad_Argument;
 901                   end case;
 902
 903                else
 904                   Add_File (Arg, Source_Index);
 905                end if;
 906             end if;
 907          end;
 908
 909          Index := Index + 1;
 910       end loop;
 911    end Parse_Cmd_Line;
 912
 913    -----------------------
 914    -- Repinfo_File_Name --
 915    -----------------------
 916
 917    function Repinfo_File_Name (Source : File_Name_Type) return String is
 918    begin
 919       return Get_Name_String (Source) & Repinfo_Suffix;
 920    end Repinfo_File_Name;
 921
 922    --------------------
 923    -- Tree_File_Name --
 924    --------------------
 925
 926    function Tree_File_Name (Source : File_Name_Type) return String is
 927       Src : constant String := Get_Name_String (Source);
 928
 929    begin
 930       --  If source name has an extension, then replace it with the tree suffix
 931
 932       for Index in reverse Src'First + 1 .. Src'Last loop
 933          if Src (Index) = '.' then
 934             return Src (Src'First .. Index - 1) & Tree_Suffix;
 935          end if;
 936       end loop;
 937
 938       --  If there is no dot, or if it is the first character, just add the
 939       --  tree suffix.
 940
 941       return Src & Tree_Suffix;
 942    end Tree_File_Name;
 943
 944    -----------
 945    -- Usage --
 946    -----------
 947
 948    procedure Usage is
 949    begin
 950       if not Usage_Displayed then
 951          Usage_Displayed := True;
 952          Display_Copyright;
 953          Put_Line ("Usage: gnatclean [switches] {[-innn] name}");
 954          New_Line;
 955
 956          Display_Usage_Version_And_Help;
 957
 958          Put_Line ("  names is one or more file names from which " &
 959                    "the .adb or .ads suffix may be omitted");
 960          Put_Line ("  names may be omitted if -P<project> is specified");
 961          New_Line;
 962
 963          Put_Line ("  --subdirs=dir real obj/lib/exec dirs are subdirs");
 964          Put_Line ("  " & Make_Util.Unchecked_Shared_Lib_Imports);
 965          Put_Line ("       Allow shared libraries to import static libraries");
 966          New_Line;
 967
 968          Put_Line ("  -c       Only delete compiler generated files");
 969          Put_Line ("  -D dir   Specify dir as the object library");
 970          Put_Line ("  -eL      Follow symbolic links when processing " &
 971                    "project files");
 972          Put_Line ("  -f       Force deletions of unwritable files");
 973          Put_Line ("  -F       Full project path name " &
 974                    "in brief error messages");
 975          Put_Line ("  -h       Display this message");
 976          Put_Line ("  -innn    Index of unit in source for following names");
 977          Put_Line ("  -n       Nothing to do: only list files to delete");
 978          Put_Line ("  -Pproj   Use GNAT Project File proj");
 979          Put_Line ("  -q       Be quiet/terse");
 980          Put_Line ("  -r       Clean all projects recursively");
 981          Put_Line ("  -v       Verbose mode");
 982          Put_Line ("  -vPx     Specify verbosity when parsing " &
 983                    "GNAT Project Files");
 984          Put_Line ("  -Xnm=val Specify an external reference " &
 985                    "for GNAT Project Files");
 986          New_Line;
 987
 988          Put_Line ("  -aPdir   Add directory dir to project search path");
 989          New_Line;
 990
 991          Put_Line ("  -aOdir   Specify ALI/object files search path");
 992          Put_Line ("  -Idir    Like -aOdir");
 993          Put_Line ("  -I-      Don't look for source/library files " &
 994                    "in the default directory");
 995          New_Line;
 996       end if;
 997    end Usage;
 998
 999 end Clean;