1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2003-2019, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Make_Util; use Make_Util;
28 with Namet; use Namet;
30 with Osint; use Osint;
31 with Osint.M; use Osint.M;
32 with Switch; use Switch;
35 with Types; use Types;
37 with Ada.Command_Line; use Ada.Command_Line;
39 with GNAT.Command_Line; use GNAT.Command_Line;
40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
41 with GNAT.IO; use GNAT.IO;
42 with GNAT.OS_Lib; use GNAT.OS_Lib;
46 -- Suffixes of various files
48 Assembly_Suffix : constant String := ".s";
49 Tree_Suffix : constant String := ".adt";
50 Object_Suffix : constant String := Get_Target_Object_Suffix.all;
51 Debug_Suffix : constant String := ".dg";
52 Repinfo_Suffix : constant String := ".rep";
53 -- Suffix of representation info files
55 B_Start : constant String := "b~";
56 -- Prefix of binder generated file, and number of actual characters used
58 Object_Directory_Path : String_Access := null;
59 -- The path name of the object directory, set with switch -D
61 Force_Deletions : Boolean := False;
62 -- Set to True by switch -f. When True, attempts to delete non writable
63 -- files will be done.
65 Do_Nothing : Boolean := False;
66 -- Set to True when switch -n is specified. When True, no file is deleted.
67 -- gnatclean only lists the files that would have been deleted if the
68 -- switch -n had not been specified.
70 File_Deleted : Boolean := False;
71 -- Set to True if at least one file has been deleted
73 Copyright_Displayed : Boolean := False;
74 Usage_Displayed : Boolean := False;
76 Project_File_Name : String_Access := null;
78 package Sources is new Table.Table
79 (Table_Component_Type => File_Name_Type,
80 Table_Index_Type => Natural,
83 Table_Increment => 100,
84 Table_Name => "Clean.Processed_Projects");
85 -- Table to store all the source files of a library unit: spec, body and
86 -- subunits, to detect .dg files and delete them.
88 -----------------------------
89 -- Other local subprograms --
90 -----------------------------
92 function Assembly_File_Name (Source : File_Name_Type) return String;
93 -- Returns the assembly file name corresponding to Source
95 procedure Clean_Executables;
96 -- Do the cleaning work when no project file is specified
98 function Debug_File_Name (Source : File_Name_Type) return String;
99 -- Name of the expanded source file corresponding to Source
101 procedure Delete (In_Directory : String; File : String);
102 -- Delete one file, or list the file name if switch -n is specified
104 procedure Delete_Binder_Generated_Files
106 Source : File_Name_Type);
107 -- Delete the binder generated file in directory Dir for Source, if they
108 -- exist: for Unix these are b~<source>.ads, b~<source>.adb,
109 -- b~<source>.ali and b~<source>.o.
111 procedure Display_Copyright;
112 -- Display the Copyright notice. If called several times, display the
113 -- Copyright notice only the first time.
115 procedure Initialize;
116 -- Call the necessary package initializations
118 function Object_File_Name (Source : File_Name_Type) return String;
119 -- Returns the object file name corresponding to Source
121 procedure Parse_Cmd_Line;
122 -- Parse the command line
124 function Repinfo_File_Name (Source : File_Name_Type) return String;
125 -- Returns the repinfo file name corresponding to Source
127 function Tree_File_Name (Source : File_Name_Type) return String;
128 -- Returns the tree file name corresponding to Source
131 -- Display the usage. If called several times, the usage is displayed only
134 ------------------------
135 -- Assembly_File_Name --
136 ------------------------
138 function Assembly_File_Name (Source : File_Name_Type) return String is
139 Src : constant String := Get_Name_String (Source);
142 -- If the source name has an extension, then replace it with
143 -- the assembly suffix.
145 for Index in reverse Src'First + 1 .. Src'Last loop
146 if Src (Index) = '.' then
147 return Src (Src'First .. Index - 1) & Assembly_Suffix;
151 -- If there is no dot, or if it is the first character, just add the
154 return Src & Assembly_Suffix;
155 end Assembly_File_Name;
157 -----------------------
158 -- Clean_Executables --
159 -----------------------
161 procedure Clean_Executables is
162 Main_Source_File : File_Name_Type;
163 -- Current main source
165 Main_Lib_File : File_Name_Type;
166 -- ALI file of the current main
168 Lib_File : File_Name_Type;
171 Full_Lib_File : File_Name_Type;
172 -- Full name of the current ALI file
174 Text : Text_Buffer_Ptr;
177 Source : Queue.Source_Info;
182 -- It does not really matter if there is or not an object file
183 -- corresponding to an ALI file: if there is one, it will be deleted.
185 Opt.Check_Object_Consistency := False;
187 -- Proceed each executable one by one. Each source is marked as it is
188 -- processed, so common sources between executables will not be
189 -- processed several times.
191 for N_File in 1 .. Osint.Number_Of_Files loop
192 Main_Source_File := Next_Main_Source;
194 Osint.Lib_File_Name (Main_Source_File, Current_File_Index);
196 if Main_Lib_File /= No_File then
198 ((File => Main_Lib_File,
199 Unit => No_Unit_Name,
203 while not Queue.Is_Empty loop
204 Sources.Set_Last (0);
205 Queue.Extract (Found, Source);
206 pragma Assert (Found);
207 pragma Assert (Source.File /= No_File);
208 Lib_File := Source.File;
209 Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
211 -- If we have existing ALI file that is not read-only, process it
213 if Full_Lib_File /= No_File
214 and then not Is_Readonly_Library (Full_Lib_File)
216 Text := Read_Library_Info (Lib_File);
220 Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
223 -- If no error was produced while loading this ALI file,
224 -- insert into the queue all the unmarked withed sources.
226 if The_ALI /= No_ALI_Id then
227 for J in ALIs.Table (The_ALI).First_Unit ..
228 ALIs.Table (The_ALI).Last_Unit
230 Sources.Increment_Last;
231 Sources.Table (Sources.Last) :=
232 ALI.Units.Table (J).Sfile;
234 for K in ALI.Units.Table (J).First_With ..
235 ALI.Units.Table (J).Last_With
237 if Withs.Table (K).Afile /= No_File then
239 ((File => Withs.Table (K).Afile,
240 Unit => No_Unit_Name,
246 -- Look for subunits and put them in the Sources table
248 for J in ALIs.Table (The_ALI).First_Sdep ..
249 ALIs.Table (The_ALI).Last_Sdep
251 if Sdep.Table (J).Subunit_Name /= No_Name then
252 Sources.Increment_Last;
253 Sources.Table (Sources.Last) :=
254 Sdep.Table (J).Sfile;
260 -- Now delete all existing files corresponding to this ALI file
263 Obj_Dir : constant String :=
264 Dir_Name (Get_Name_String (Full_Lib_File));
265 Obj : constant String := Object_File_Name (Lib_File);
266 Adt : constant String := Tree_File_Name (Lib_File);
267 Asm : constant String := Assembly_File_Name (Lib_File);
270 Delete (Obj_Dir, Get_Name_String (Lib_File));
272 if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then
273 Delete (Obj_Dir, Obj);
276 if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then
277 Delete (Obj_Dir, Adt);
280 if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then
281 Delete (Obj_Dir, Asm);
284 -- Delete expanded source files (.dg) and/or repinfo files
287 for J in 1 .. Sources.Last loop
289 Deb : constant String :=
290 Debug_File_Name (Sources.Table (J));
291 Rep : constant String :=
292 Repinfo_File_Name (Sources.Table (J));
295 if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
296 Delete (Obj_Dir, Deb);
299 if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then
300 Delete (Obj_Dir, Rep);
308 -- Delete the executable, if it exists, and the binder generated
311 if not Compile_Only then
313 Source : constant File_Name_Type :=
314 Strip_Suffix (Main_Lib_File);
315 Executable : constant String :=
316 Get_Name_String (Executable_Name (Source));
318 if Is_Regular_File (Executable) then
319 Delete ("", Executable);
322 Delete_Binder_Generated_Files (Get_Current_Dir, Source);
326 end Clean_Executables;
328 ---------------------
329 -- Debug_File_Name --
330 ---------------------
332 function Debug_File_Name (Source : File_Name_Type) return String is
334 return Get_Name_String (Source) & Debug_Suffix;
341 procedure Delete (In_Directory : String; File : String) is
342 Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
347 -- Indicate that at least one file is deleted or is to be deleted
349 File_Deleted := True;
351 -- Build the path name of the file to delete
353 Last := In_Directory'Length;
354 Full_Name (1 .. Last) := In_Directory;
356 if Last > 0 and then Full_Name (Last) /= Directory_Separator then
358 Full_Name (Last) := Directory_Separator;
361 Full_Name (Last + 1 .. Last + File'Length) := File;
362 Last := Last + File'Length;
364 -- If switch -n was used, simply output the path name
367 Put_Line (Full_Name (1 .. Last));
369 -- Otherwise, delete the file if it is writable
373 or else Is_Writable_File (Full_Name (1 .. Last))
374 or else Is_Symbolic_Link (Full_Name (1 .. Last))
376 Delete_File (Full_Name (1 .. Last), Success);
378 -- Here if no deletion required
384 if Verbose_Mode or else not Quiet_Output then
387 Put (Full_Name (1 .. Last));
388 Put_Line (""" could not be deleted");
392 Put (Full_Name (1 .. Last));
393 Put_Line (""" has been deleted");
399 -----------------------------------
400 -- Delete_Binder_Generated_Files --
401 -----------------------------------
403 procedure Delete_Binder_Generated_Files
405 Source : File_Name_Type)
407 Source_Name : constant String := Get_Name_String (Source);
408 Current : constant String := Get_Current_Dir;
409 Last : constant Positive := B_Start'Length + Source_Name'Length;
410 File_Name : String (1 .. Last + 4);
415 -- Build the file name (before the extension)
417 File_Name (1 .. B_Start'Length) := B_Start;
418 File_Name (B_Start'Length + 1 .. Last) := Source_Name;
422 File_Name (Last + 1 .. Last + 4) := ".ads";
424 if Is_Regular_File (File_Name (1 .. Last + 4)) then
425 Delete (Dir, File_Name (1 .. Last + 4));
430 File_Name (Last + 1 .. Last + 4) := ".adb";
432 if Is_Regular_File (File_Name (1 .. Last + 4)) then
433 Delete (Dir, File_Name (1 .. Last + 4));
438 File_Name (Last + 1 .. Last + 4) := ".ali";
440 if Is_Regular_File (File_Name (1 .. Last + 4)) then
441 Delete (Dir, File_Name (1 .. Last + 4));
446 File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix;
448 if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then
449 Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length));
452 -- Change back to previous directory
454 Change_Dir (Current);
455 end Delete_Binder_Generated_Files;
457 -----------------------
458 -- Display_Copyright --
459 -----------------------
461 procedure Display_Copyright is
463 if not Copyright_Displayed then
464 Copyright_Displayed := True;
465 Display_Version ("GNATCLEAN", "2003");
467 end Display_Copyright;
473 procedure Gnatclean is
475 -- Do the necessary initializations
479 -- Parse the command line, getting the switches and the executable names
487 Osint.Add_Default_Search_Dirs;
488 Targparm.Get_Target_Parameters;
490 if Osint.Number_Of_Files = 0 then
491 if Argument_Count = 0 then
504 if Project_File_Name /= null then
506 Gprclean_Path : constant String_Access :=
507 Locate_Exec_On_Path ("gprclean");
508 Arg_Len : Natural := Argument_Count;
510 Target : String_Access := null;
511 Success : Boolean := False;
513 if Gprclean_Path = null then
515 ("project files are no longer supported by gnatclean;" &
516 " use gprclean instead");
522 and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
524 Target := new String'(Name_Buffer (1 .. Name_Len - 9));
525 Arg_Len := Arg_Len + 1;
529 Args : Argument_List (1 .. Arg_Len);
531 if Target /= null then
532 Args (1) := new String'("--target=" & Target.all);
536 for J in 1 .. Argument_Count loop
538 Args (Pos) := new String'(Argument (J));
541 Spawn (Gprclean_Path.all, Args, Success);
544 Exit_Program (E_Success);
546 Exit_Program (E_Errors);
554 -- In verbose mode, if Delete has not been called, indicate that no file
555 -- needs to be deleted.
557 if Verbose_Mode and (not File_Deleted) then
561 Put_Line ("No file needs to be deleted");
563 Put_Line ("No file has been deleted");
572 procedure Initialize is
574 -- Reset global variables
576 Free (Object_Directory_Path);
578 File_Deleted := False;
579 Copyright_Displayed := False;
580 Usage_Displayed := False;
583 ----------------------
584 -- Object_File_Name --
585 ----------------------
587 function Object_File_Name (Source : File_Name_Type) return String is
588 Src : constant String := Get_Name_String (Source);
591 -- If the source name has an extension, then replace it with
592 -- the Object suffix.
594 for Index in reverse Src'First + 1 .. Src'Last loop
595 if Src (Index) = '.' then
596 return Src (Src'First .. Index - 1) & Object_Suffix;
600 -- If there is no dot, or if it is the first character, just add the
603 return Src & Object_Suffix;
604 end Object_File_Name;
610 procedure Parse_Cmd_Line is
611 Last : constant Natural := Argument_Count;
613 Source_Index : Int := 0;
615 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
618 -- First, check for --version and --help
620 Check_Version_And_Help ("GNATCLEAN", "2003");
622 -- First, check for switch -P and, if found and gprclean is available,
623 -- silently invoke gprclean, with switch --target if not on a native
627 Arg_Len : Positive := Argument_Count;
628 Call_Gprclean : Boolean := False;
629 Gprclean : String_Access := null;
632 Target : String_Access := null;
638 and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
641 Target := new String'(Name_Buffer (1 .. Name_Len - 10));
642 Arg_Len := Arg_Len + 1;
645 for J in 1 .. Argument_Count loop
647 Arg : constant String := Argument (J);
650 and then Arg (Arg'First .. Arg'First + 1) = "-P"
652 Call_Gprclean := True;
658 if Call_Gprclean then
659 Gprclean := Locate_Exec_On_Path (Exec_Name => "gprclean");
661 if Gprclean /= null then
663 Args : Argument_List (1 .. Arg_Len);
665 if Target /= null then
666 Args (1) := new String'("--target=" & Target.all);
670 for J in 1 .. Argument_Count loop
672 Args (Pos) := new String'(Argument (J));
675 Spawn (Gprclean.all, Args, Success);
680 Exit_Program (E_Success);
683 Exit_Program (E_Fatal);
692 while Index <= Last loop
694 Arg : constant String := Argument (Index);
696 procedure Bad_Argument;
697 pragma No_Return (Bad_Argument);
698 -- Signal bad argument
704 procedure Bad_Argument is
706 Fail ("invalid argument """ & Arg & """");
710 if Arg'Length /= 0 then
711 if Arg (1) = '-' then
712 if Arg'Length = 1 then
718 if Arg'Length > Subdirs_Option'Length
720 Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
723 -- Subdirs are only used in gprclean
725 elsif Arg = Make_Util.Unchecked_Shared_Lib_Imports then
726 Opt.Unchecked_Shared_Lib_Imports := True;
733 if Arg'Length < 4 then
737 if Arg (3) = 'O' then
738 Add_Lib_Search_Dir (Arg (4 .. Arg'Last));
740 elsif Arg (3) = 'P' then
742 -- This is only for gprclean
749 Compile_Only := True;
752 if Object_Directory_Path /= null then
753 Fail ("duplicate -D switch");
755 elsif Project_File_Name /= null then
756 Fail ("-P and -D cannot be used simultaneously");
759 if Arg'Length > 2 then
761 Dir : constant String := Arg (3 .. Arg'Last);
763 if not Is_Directory (Dir) then
764 Fail (Dir & " is not a directory");
766 Add_Lib_Search_Dir (Dir);
772 Fail ("no directory specified after -D");
778 Dir : constant String := Argument (Index);
780 if not Is_Directory (Dir) then
781 Fail (Dir & " is not a directory");
783 Add_Lib_Search_Dir (Dir);
790 Follow_Links_For_Files := True;
791 Follow_Links_For_Dirs := True;
798 Force_Deletions := True;
799 Directories_Must_Exist_In_Projects := False;
802 Full_Path_Name_For_Brief_Errors := True;
808 if Arg'Length = 2 then
814 for J in 3 .. Arg'Last loop
815 if Arg (J) not in '0' .. '9' then
820 (20 * Source_Index) +
821 (Character'Pos (Arg (J)) - Character'Pos ('0'));
826 Opt.Look_In_Primary_Dir := False;
829 if Arg'Length = 2 then
833 Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
840 if Project_File_Name /= null then
841 Fail ("multiple -P switches");
843 elsif Object_Directory_Path /= null then
844 Fail ("-D and -P cannot be used simultaneously");
848 if Arg'Length > 2 then
850 Prj : constant String := Arg (3 .. Arg'Last);
853 and then Prj (Prj'First) = '='
857 (Prj (Prj'First + 1 .. Prj'Last));
859 Project_File_Name := new String'(Prj);
865 Fail ("no project specified after -P");
869 Project_File_Name := new String'(Argument (Index));
873 Quiet_Output := True;
877 -- This is only for gprclean
881 Verbose_Mode := True;
888 -- This is only for gprclean
895 if Arg'Length = 2 then
904 Add_File (Arg, Source_Index);
913 -----------------------
914 -- Repinfo_File_Name --
915 -----------------------
917 function Repinfo_File_Name (Source : File_Name_Type) return String is
919 return Get_Name_String (Source) & Repinfo_Suffix;
920 end Repinfo_File_Name;
926 function Tree_File_Name (Source : File_Name_Type) return String is
927 Src : constant String := Get_Name_String (Source);
930 -- If source name has an extension, then replace it with the tree suffix
932 for Index in reverse Src'First + 1 .. Src'Last loop
933 if Src (Index) = '.' then
934 return Src (Src'First .. Index - 1) & Tree_Suffix;
938 -- If there is no dot, or if it is the first character, just add the
941 return Src & Tree_Suffix;
950 if not Usage_Displayed then
951 Usage_Displayed := True;
953 Put_Line ("Usage: gnatclean [switches] {[-innn] name}");
956 Display_Usage_Version_And_Help;
958 Put_Line (" names is one or more file names from which " &
959 "the .adb or .ads suffix may be omitted");
960 Put_Line (" names may be omitted if -P<project> is specified");
963 Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs");
964 Put_Line (" " & Make_Util.Unchecked_Shared_Lib_Imports);
965 Put_Line (" Allow shared libraries to import static libraries");
968 Put_Line (" -c Only delete compiler generated files");
969 Put_Line (" -D dir Specify dir as the object library");
970 Put_Line (" -eL Follow symbolic links when processing " &
972 Put_Line (" -f Force deletions of unwritable files");
973 Put_Line (" -F Full project path name " &
974 "in brief error messages");
975 Put_Line (" -h Display this message");
976 Put_Line (" -innn Index of unit in source for following names");
977 Put_Line (" -n Nothing to do: only list files to delete");
978 Put_Line (" -Pproj Use GNAT Project File proj");
979 Put_Line (" -q Be quiet/terse");
980 Put_Line (" -r Clean all projects recursively");
981 Put_Line (" -v Verbose mode");
982 Put_Line (" -vPx Specify verbosity when parsing " &
983 "GNAT Project Files");
984 Put_Line (" -Xnm=val Specify an external reference " &
985 "for GNAT Project Files");
988 Put_Line (" -aPdir Add directory dir to project search path");
991 Put_Line (" -aOdir Specify ALI/object files search path");
992 Put_Line (" -Idir Like -aOdir");
993 Put_Line (" -I- Don't look for source/library files " &
994 "in the default directory");