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