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