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