------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C L E A N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2023, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with ALI; use ALI; with Make_Util; use Make_Util; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Osint.M; use Osint.M; with Switch; use Switch; with Table; with Targparm; with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.IO; use GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; package body Clean is -- Suffixes of various files Assembly_Suffix : constant String := ".s"; Tree_Suffix : constant String := ".adt"; Object_Suffix : constant String := Get_Target_Object_Suffix.all; Debug_Suffix : constant String := ".dg"; Repinfo_Suffix : constant String := ".rep"; -- Suffix of representation info files B_Start : constant String := "b~"; -- Prefix of binder generated file, and number of actual characters used Object_Directory_Path : String_Access := null; -- The path name of the object directory, set with switch -D Force_Deletions : Boolean := False; -- Set to True by switch -f. When True, attempts to delete non writable -- files will be done. Do_Nothing : Boolean := False; -- Set to True when switch -n is specified. When True, no file is deleted. -- gnatclean only lists the files that would have been deleted if the -- switch -n had not been specified. File_Deleted : Boolean := False; -- Set to True if at least one file has been deleted Copyright_Displayed : Boolean := False; Usage_Displayed : Boolean := False; Project_File_Name : String_Access := null; package Sources is new Table.Table (Table_Component_Type => File_Name_Type, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 100, Table_Name => "Clean.Processed_Projects"); -- Table to store all the source files of a library unit: spec, body and -- subunits, to detect .dg files and delete them. ----------------------------- -- Other local subprograms -- ----------------------------- function Assembly_File_Name (Source : File_Name_Type) return String; -- Returns the assembly file name corresponding to Source procedure Clean_Executables; -- Do the cleaning work when no project file is specified function Debug_File_Name (Source : File_Name_Type) return String; -- Name of the expanded source file corresponding to Source procedure Delete (In_Directory : String; File : String); -- Delete one file, or list the file name if switch -n is specified procedure Delete_Binder_Generated_Files (Dir : String; Source : File_Name_Type); -- Delete the binder generated file in directory Dir for Source, if they -- exist: for Unix these are b~.ads, b~.adb, -- b~.ali and b~.o. procedure Display_Copyright; -- Display the Copyright notice. If called several times, display the -- Copyright notice only the first time. procedure Initialize; -- Call the necessary package initializations function Object_File_Name (Source : File_Name_Type) return String; -- Returns the object file name corresponding to Source procedure Parse_Cmd_Line; -- Parse the command line function Repinfo_File_Name (Source : File_Name_Type) return String; -- Returns the repinfo file name corresponding to Source function Tree_File_Name (Source : File_Name_Type) return String; -- Returns the tree file name corresponding to Source procedure Usage; -- Display the usage. If called several times, the usage is displayed only -- the first time. ------------------------ -- Assembly_File_Name -- ------------------------ function Assembly_File_Name (Source : File_Name_Type) return String is Src : constant String := Get_Name_String (Source); begin -- If the source name has an extension, then replace it with -- the assembly suffix. for Index in reverse Src'First + 1 .. Src'Last loop if Src (Index) = '.' then return Src (Src'First .. Index - 1) & Assembly_Suffix; end if; end loop; -- If there is no dot, or if it is the first character, just add the -- assembly suffix. return Src & Assembly_Suffix; end Assembly_File_Name; ----------------------- -- Clean_Executables -- ----------------------- procedure Clean_Executables is Main_Source_File : File_Name_Type; -- Current main source Main_Lib_File : File_Name_Type; -- ALI file of the current main Lib_File : File_Name_Type; -- Current ALI file Full_Lib_File : File_Name_Type; -- Full name of the current ALI file Text : Text_Buffer_Ptr; The_ALI : ALI_Id; Found : Boolean; Source : Queue.Source_Info; begin Queue.Initialize; -- It does not really matter if there is or not an object file -- corresponding to an ALI file: if there is one, it will be deleted. Opt.Check_Object_Consistency := False; -- Proceed each executable one by one. Each source is marked as it is -- processed, so common sources between executables will not be -- processed several times. for N_File in 1 .. Osint.Number_Of_Files loop Main_Source_File := Next_Main_Source; Main_Lib_File := Osint.Lib_File_Name (Main_Source_File, Current_File_Index); if Main_Lib_File /= No_File then Queue.Insert ((File => Main_Lib_File, Unit => No_Unit_Name, Index => 0)); end if; while not Queue.Is_Empty loop Sources.Set_Last (0); Queue.Extract (Found, Source); pragma Assert (Found); pragma Assert (Source.File /= No_File); Lib_File := Source.File; Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); -- If we have existing ALI file that is not read-only, process it if Full_Lib_File /= No_File and then not Is_Readonly_Library (Full_Lib_File) then Text := Read_Library_Info (Lib_File); if Text /= null then The_ALI := Scan_ALI (Lib_File, Text, Err => True); Free (Text); -- If no error was produced while loading this ALI file, -- insert into the queue all the unmarked withed sources. if The_ALI /= No_ALI_Id then for J in ALIs.Table (The_ALI).First_Unit .. ALIs.Table (The_ALI).Last_Unit loop Sources.Increment_Last; Sources.Table (Sources.Last) := ALI.Units.Table (J).Sfile; for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop if Withs.Table (K).Afile /= No_File then Queue.Insert ((File => Withs.Table (K).Afile, Unit => No_Unit_Name, Index => 0)); end if; end loop; end loop; -- Look for subunits and put them in the Sources table for J in ALIs.Table (The_ALI).First_Sdep .. ALIs.Table (The_ALI).Last_Sdep loop if Sdep.Table (J).Subunit_Name /= No_Name then Sources.Increment_Last; Sources.Table (Sources.Last) := Sdep.Table (J).Sfile; end if; end loop; end if; end if; -- Now delete all existing files corresponding to this ALI file declare Obj_Dir : constant String := Dir_Name (Get_Name_String (Full_Lib_File)); Obj : constant String := Object_File_Name (Lib_File); Adt : constant String := Tree_File_Name (Lib_File); Asm : constant String := Assembly_File_Name (Lib_File); begin Delete (Obj_Dir, Get_Name_String (Lib_File)); if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then Delete (Obj_Dir, Obj); end if; if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then Delete (Obj_Dir, Adt); end if; if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then Delete (Obj_Dir, Asm); end if; -- Delete expanded source files (.dg) and/or repinfo files -- (.rep) if any for J in 1 .. Sources.Last loop declare Deb : constant String := Debug_File_Name (Sources.Table (J)); Rep : constant String := Repinfo_File_Name (Sources.Table (J)); begin if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then Delete (Obj_Dir, Deb); end if; if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then Delete (Obj_Dir, Rep); end if; end; end loop; end; end if; end loop; -- Delete the executable, if it exists, and the binder generated -- files, if any. if not Compile_Only then declare Source : constant File_Name_Type := Strip_Suffix (Main_Lib_File); Executable : constant String := Get_Name_String (Executable_Name (Source)); begin if Is_Regular_File (Executable) then Delete ("", Executable); end if; Delete_Binder_Generated_Files (Get_Current_Dir, Source); end; end if; end loop; end Clean_Executables; --------------------- -- Debug_File_Name -- --------------------- function Debug_File_Name (Source : File_Name_Type) return String is begin return Get_Name_String (Source) & Debug_Suffix; end Debug_File_Name; ------------ -- Delete -- ------------ procedure Delete (In_Directory : String; File : String) is Full_Name : String (1 .. In_Directory'Length + File'Length + 1); Last : Natural := 0; Success : Boolean; begin -- Indicate that at least one file is deleted or is to be deleted File_Deleted := True; -- Build the path name of the file to delete Last := In_Directory'Length; Full_Name (1 .. Last) := In_Directory; if Last > 0 and then Full_Name (Last) /= Directory_Separator then Last := Last + 1; Full_Name (Last) := Directory_Separator; end if; Full_Name (Last + 1 .. Last + File'Length) := File; Last := Last + File'Length; -- If switch -n was used, simply output the path name if Do_Nothing then Put_Line (Full_Name (1 .. Last)); -- Otherwise, delete the file if it is writable else if Force_Deletions or else Is_Writable_File (Full_Name (1 .. Last)) or else Is_Symbolic_Link (Full_Name (1 .. Last)) then Delete_File (Full_Name (1 .. Last), Success); -- Here if no deletion required else Success := False; end if; if Verbose_Mode or else not Quiet_Output then if not Success then Put ("Warning: """); Put (Full_Name (1 .. Last)); Put_Line (""" could not be deleted"); else Put (""""); Put (Full_Name (1 .. Last)); Put_Line (""" has been deleted"); end if; end if; end if; end Delete; ----------------------------------- -- Delete_Binder_Generated_Files -- ----------------------------------- procedure Delete_Binder_Generated_Files (Dir : String; Source : File_Name_Type) is Source_Name : constant String := Get_Name_String (Source); Current : constant String := Get_Current_Dir; Last : constant Positive := B_Start'Length + Source_Name'Length; File_Name : String (1 .. Last + 4); begin Change_Dir (Dir); -- Build the file name (before the extension) File_Name (1 .. B_Start'Length) := B_Start; File_Name (B_Start'Length + 1 .. Last) := Source_Name; -- Spec File_Name (Last + 1 .. Last + 4) := ".ads"; if Is_Regular_File (File_Name (1 .. Last + 4)) then Delete (Dir, File_Name (1 .. Last + 4)); end if; -- Body File_Name (Last + 1 .. Last + 4) := ".adb"; if Is_Regular_File (File_Name (1 .. Last + 4)) then Delete (Dir, File_Name (1 .. Last + 4)); end if; -- ALI file File_Name (Last + 1 .. Last + 4) := ".ali"; if Is_Regular_File (File_Name (1 .. Last + 4)) then Delete (Dir, File_Name (1 .. Last + 4)); end if; -- Object file File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix; if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length)); end if; -- Change back to previous directory Change_Dir (Current); end Delete_Binder_Generated_Files; ----------------------- -- Display_Copyright -- ----------------------- procedure Display_Copyright is begin if not Copyright_Displayed then Copyright_Displayed := True; Display_Version ("GNATCLEAN", "2003"); end if; end Display_Copyright; --------------- -- Gnatclean -- --------------- procedure Gnatclean is begin -- Do the necessary initializations Clean.Initialize; -- Parse the command line, getting the switches and the executable names Parse_Cmd_Line; if Verbose_Mode then Display_Copyright; end if; Osint.Add_Default_Search_Dirs; Targparm.Get_Target_Parameters; if Osint.Number_Of_Files = 0 then if Argument_Count = 0 then Usage; else Try_Help; end if; return; end if; if Verbose_Mode then New_Line; end if; if Project_File_Name /= null then declare Gprclean_Path : constant String_Access := Locate_Exec_On_Path ("gprclean"); Arg_Len : Natural := Argument_Count; Pos : Natural := 0; Target : String_Access := null; Success : Boolean := False; begin if Gprclean_Path = null then Fail_Program ("project files are no longer supported by gnatclean;" & " use gprclean instead"); end if; Find_Program_Name; if Name_Len > 10 and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean" then Target := new String'(Name_Buffer (1 .. Name_Len - 9)); Arg_Len := Arg_Len + 1; end if; declare Args : Argument_List (1 .. Arg_Len); begin if Target /= null then Args (1) := new String'("--target=" & Target.all); Pos := 1; end if; for J in 1 .. Argument_Count loop Pos := Pos + 1; Args (Pos) := new String'(Argument (J)); end loop; Spawn (Gprclean_Path.all, Args, Success); if Success then Exit_Program (E_Success); else Exit_Program (E_Errors); end if; end; end; end if; Clean_Executables; -- In verbose mode, if Delete has not been called, indicate that no file -- needs to be deleted. if Verbose_Mode and not File_Deleted then New_Line; if Do_Nothing then Put_Line ("No file needs to be deleted"); else Put_Line ("No file has been deleted"); end if; end if; end Gnatclean; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Reset global variables Free (Object_Directory_Path); Do_Nothing := False; File_Deleted := False; Copyright_Displayed := False; Usage_Displayed := False; end Initialize; ---------------------- -- Object_File_Name -- ---------------------- function Object_File_Name (Source : File_Name_Type) return String is Src : constant String := Get_Name_String (Source); begin -- If the source name has an extension, then replace it with -- the Object suffix. for Index in reverse Src'First + 1 .. Src'Last loop if Src (Index) = '.' then return Src (Src'First .. Index - 1) & Object_Suffix; end if; end loop; -- If there is no dot, or if it is the first character, just add the -- ALI suffix. return Src & Object_Suffix; end Object_File_Name; -------------------- -- Parse_Cmd_Line -- -------------------- procedure Parse_Cmd_Line is Last : constant Natural := Argument_Count; Index : Positive; Source_Index : Int := 0; procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); begin -- First, check for --version and --help Check_Version_And_Help ("GNATCLEAN", "2003"); -- First, check for switch -P and, if found and gprclean is available, -- silently invoke gprclean, with switch --target if not on a native -- platform. declare Arg_Len : Positive := Argument_Count; Call_Gprclean : Boolean := False; Gprclean : String_Access := null; Pos : Natural := 0; Success : Boolean; Target : String_Access := null; begin Find_Program_Name; if Name_Len >= 9 and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean" then if Name_Len > 9 then Target := new String'(Name_Buffer (1 .. Name_Len - 10)); Arg_Len := Arg_Len + 1; end if; for J in 1 .. Argument_Count loop declare Arg : constant String := Argument (J); begin if Arg'Length >= 2 and then Arg (Arg'First .. Arg'First + 1) = "-P" then Call_Gprclean := True; exit; end if; end; end loop; if Call_Gprclean then Gprclean := Locate_Exec_On_Path (Exec_Name => "gprclean"); if Gprclean /= null then declare Args : Argument_List (1 .. Arg_Len); begin if Target /= null then Args (1) := new String'("--target=" & Target.all); Pos := 1; end if; for J in 1 .. Argument_Count loop Pos := Pos + 1; Args (Pos) := new String'(Argument (J)); end loop; Spawn (Gprclean.all, Args, Success); Free (Gprclean); if Success then Exit_Program (E_Success); else Exit_Program (E_Fatal); end if; end; end if; end if; end if; end; Index := 1; while Index <= Last loop declare Arg : constant String := Argument (Index); procedure Bad_Argument; pragma No_Return (Bad_Argument); -- Signal bad argument ------------------ -- Bad_Argument -- ------------------ procedure Bad_Argument is begin Fail ("invalid argument """ & Arg & """"); end Bad_Argument; begin if Arg'Length /= 0 then if Arg (1) = '-' then if Arg'Length = 1 then Bad_Argument; end if; case Arg (2) is when '-' => if Arg'Length > Subdirs_Option'Length and then Arg (1 .. Subdirs_Option'Length) = Subdirs_Option then null; -- Subdirs are only used in gprclean elsif Arg = Make_Util.Unchecked_Shared_Lib_Imports then Opt.Unchecked_Shared_Lib_Imports := True; else Bad_Argument; end if; when 'a' => if Arg'Length < 4 then Bad_Argument; end if; if Arg (3) = 'O' then Add_Lib_Search_Dir (Arg (4 .. Arg'Last)); elsif Arg (3) = 'P' then null; -- This is only for gprclean else Bad_Argument; end if; when 'c' => Compile_Only := True; when 'D' => if Object_Directory_Path /= null then Fail ("duplicate -D switch"); elsif Project_File_Name /= null then Fail ("-P and -D cannot be used simultaneously"); end if; if Arg'Length > 2 then declare Dir : constant String := Arg (3 .. Arg'Last); begin if not Is_Directory (Dir) then Fail (Dir & " is not a directory"); else Add_Lib_Search_Dir (Dir); end if; end; else if Index = Last then Fail ("no directory specified after -D"); end if; Index := Index + 1; declare Dir : constant String := Argument (Index); begin if not Is_Directory (Dir) then Fail (Dir & " is not a directory"); else Add_Lib_Search_Dir (Dir); end if; end; end if; when 'e' => if Arg = "-eL" then Follow_Links_For_Files := True; Follow_Links_For_Dirs := True; else Bad_Argument; end if; when 'f' => Force_Deletions := True; Directories_Must_Exist_In_Projects := False; when 'F' => Full_Path_Name_For_Brief_Errors := True; when 'h' => Usage; when 'i' => if Arg'Length = 2 then Bad_Argument; end if; Source_Index := 0; for J in 3 .. Arg'Last loop if Arg (J) not in '0' .. '9' then Bad_Argument; end if; Source_Index := (20 * Source_Index) + (Character'Pos (Arg (J)) - Character'Pos ('0')); end loop; when 'I' => if Arg = "-I-" then Opt.Look_In_Primary_Dir := False; else if Arg'Length = 2 then Bad_Argument; end if; Add_Lib_Search_Dir (Arg (3 .. Arg'Last)); end if; when 'n' => Do_Nothing := True; when 'P' => if Project_File_Name /= null then Fail ("multiple -P switches"); elsif Object_Directory_Path /= null then Fail ("-D and -P cannot be used simultaneously"); end if; if Arg'Length > 2 then declare Prj : constant String := Arg (3 .. Arg'Last); begin if Prj'Length > 1 and then Prj (Prj'First) = '=' then Project_File_Name := new String' (Prj (Prj'First + 1 .. Prj'Last)); else Project_File_Name := new String'(Prj); end if; end; else if Index = Last then Fail ("no project specified after -P"); end if; Index := Index + 1; Project_File_Name := new String'(Argument (Index)); end if; when 'q' => Quiet_Output := True; when 'r' => null; -- This is only for gprclean when 'v' => if Arg = "-v" then Verbose_Mode := True; elsif Arg = "-vP0" or else Arg = "-vP1" or else Arg = "-vP2" then null; -- This is only for gprclean else Bad_Argument; end if; when 'X' => if Arg'Length = 2 then Bad_Argument; end if; when others => Bad_Argument; end case; else Add_File (Arg, Source_Index); end if; end if; end; Index := Index + 1; end loop; end Parse_Cmd_Line; ----------------------- -- Repinfo_File_Name -- ----------------------- function Repinfo_File_Name (Source : File_Name_Type) return String is begin return Get_Name_String (Source) & Repinfo_Suffix; end Repinfo_File_Name; -------------------- -- Tree_File_Name -- -------------------- function Tree_File_Name (Source : File_Name_Type) return String is Src : constant String := Get_Name_String (Source); begin -- If source name has an extension, then replace it with the tree suffix for Index in reverse Src'First + 1 .. Src'Last loop if Src (Index) = '.' then return Src (Src'First .. Index - 1) & Tree_Suffix; end if; end loop; -- If there is no dot, or if it is the first character, just add the -- tree suffix. return Src & Tree_Suffix; end Tree_File_Name; ----------- -- Usage -- ----------- procedure Usage is begin if not Usage_Displayed then Usage_Displayed := True; Display_Copyright; Put_Line ("Usage: gnatclean [switches] {[-innn] name}"); New_Line; Display_Usage_Version_And_Help; Put_Line (" names is one or more file names from which " & "the .adb or .ads suffix may be omitted"); Put_Line (" names may be omitted if -P is specified"); New_Line; Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Put_Line (" " & Make_Util.Unchecked_Shared_Lib_Imports); Put_Line (" Allow shared libraries to import static libraries"); New_Line; Put_Line (" -c Only delete compiler generated files"); Put_Line (" -D dir Specify dir as the object library"); Put_Line (" -eL Follow symbolic links when processing " & "project files"); Put_Line (" -f Force deletions of unwritable files"); Put_Line (" -F Full project path name " & "in brief error messages"); Put_Line (" -h Display this message"); Put_Line (" -innn Index of unit in source for following names"); Put_Line (" -n Nothing to do: only list files to delete"); Put_Line (" -Pproj Use GNAT Project File proj"); Put_Line (" -q Be quiet/terse"); Put_Line (" -r Clean all projects recursively"); Put_Line (" -v Verbose mode"); Put_Line (" -vPx Specify verbosity when parsing " & "GNAT Project Files"); Put_Line (" -Xnm=val Specify an external reference " & "for GNAT Project Files"); New_Line; Put_Line (" -aPdir Add directory dir to project search path"); New_Line; Put_Line (" -aOdir Specify ALI/object files search path"); Put_Line (" -Idir Like -aOdir"); Put_Line (" -I- Don't look for source/library files " & "in the default directory"); New_Line; end if; end Usage; end Clean;