1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- C L E A N -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2003-2019, 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 26with ALI; use ALI; 27with Make_Util; use Make_Util; 28with Namet; use Namet; 29with Opt; use Opt; 30with Osint; use Osint; 31with Osint.M; use Osint.M; 32with Switch; use Switch; 33with Table; 34with Targparm; 35with Types; use Types; 36 37with Ada.Command_Line; use Ada.Command_Line; 38 39with GNAT.Command_Line; use GNAT.Command_Line; 40with GNAT.Directory_Operations; use GNAT.Directory_Operations; 41with GNAT.IO; use GNAT.IO; 42with GNAT.OS_Lib; use GNAT.OS_Lib; 43 44package 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, Ignore_ED => False, 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 999end Clean; 1000