diff options
Diffstat (limited to 'gcc/ada/clean.adb')
| -rw-r--r-- | gcc/ada/clean.adb | 1444 |
1 files changed, 1444 insertions, 0 deletions
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb new file mode 100644 index 00000000000..8f38eb39cb0 --- /dev/null +++ b/gcc/ada/clean.adb @@ -0,0 +1,1444 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C L E A N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003, 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- 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 Csets; +with Gnatvsn; +with Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Osint.M; use Osint.M; +with Prj; use Prj; +with Prj.Com; +with Prj.Env; +with Prj.Ext; +with Prj.Pars; +with Prj.Util; use Prj.Util; +with Snames; +with System; +with Table; +with Types; use Types; + +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 + + Initialized : Boolean := False; + -- Set to True by the first call to Initialize. + -- To avoid reinitialization of some packages. + + -- Suffixes of various files + + Assembly_Suffix : constant String := ".s"; + ALI_Suffix : constant String := ".ali"; + Tree_Suffix : constant String := ".adt"; + Object_Suffix : constant String := Get_Object_Suffix.all; + Debug_Suffix : String := ".dg"; + -- Changed to "_dg" for VMS in the body of the package + + Repinfo_Suffix : String := ".rep"; + -- Changed to "_rep" for VMS in the body of the package + + B_Start : String := "b~"; + -- Prefix of binder generated file. + -- Changed to "b$" for VMS in the body of the package. + + Object_Directory_Path : String_Access := null; + -- The path name of the object directory, set with switch -D + + 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; + + Main_Project : Prj.Project_Id := Prj.No_Project; + + All_Projects : Boolean := False; + + -- Packages of project files where unknown attributes are errors. + + Naming_String : aliased String := "naming"; + Builder_String : aliased String := "builder"; + Compiler_String : aliased String := "compiler"; + Binder_String : aliased String := "binder"; + Linker_String : aliased String := "linker"; + + Gnatmake_Packages : aliased String_List := + (Naming_String 'Access, + Builder_String 'Access, + Compiler_String 'Access, + Binder_String 'Access, + Linker_String 'Access); + + Packages_To_Check_By_Gnatmake : constant String_List_Access := + Gnatmake_Packages'Access; + + package Processed_Projects is new Table.Table + (Table_Component_Type => Project_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Clean.Processed_Projects"); + -- Table to keep track of what project files have been processed, when + -- switch -r is specified. + + 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 => 10, + 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. + + ---------------------------- + -- Queue (Q) manipulation -- + ---------------------------- + + procedure Init_Q; + -- Must be called to initialize the Q + + procedure Insert_Q + (Source_File : File_Name_Type); + -- If Source_File is not marked, inserts it at the end of Q and mark it + + function Empty_Q return Boolean; + -- Returns True if Q is empty. + + procedure Extract_From_Q + (Source_File : out File_Name_Type); + -- Extracts the first element from the Q. + + Q_Front : Natural; + -- Points to the first valid element in the Q. + + package Q is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 4000, + Table_Increment => 100, + Table_Name => "Clean.Q"); + -- This is the actual queue + + ----------------------------- + -- Other local subprograms -- + ----------------------------- + + procedure Add_Source_Dir (N : String); + -- Call Add_Src_Search_Dir. + -- Output one line when in verbose mode. + + procedure Add_Source_Directories is + new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir); + + procedure Add_Object_Dir (N : String); + -- Call Add_Lib_Search_Dir. + -- Output one line when in verbose mode. + + procedure Add_Object_Directories is + new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir); + + function ALI_File_Name (Source : Name_Id) return String; + -- Returns the name of the ALI file corresponding to Source + + function Assembly_File_Name (Source : Name_Id) return String; + -- Returns the assembly file name corresponding to Source + + procedure Clean_Directory (Dir : Name_Id); + -- Delete all regular files in a library directory or in a library + -- interface dir. + + procedure Clean_Executables; + -- Do the cleaning work when no project file is specified + + procedure Clean_Project (Project : Project_Id); + -- Do the cleaning work when a project file is specified. + -- This procedure calls itself recursively when there are several + -- project files in the tree rooted at the main project file and switch -r + -- has been specified. + + function Debug_File_Name (Source : Name_Id) 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 : Name_Id); + -- Delete the binder generated file in directory Dir for Source, if they + -- exist: for Unix these are b~<source>.ads, b~<source>.adb, + -- b~<source>.ali and b~<source>.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 : Name_Id) return String; + -- Returns the object file name corresponding to Source + + procedure Parse_Cmd_Line; + -- Parse the command line + + function Repinfo_File_Name (Source : Name_Id) return String; + -- Returns the repinfo file name corresponding to Source + + function Tree_File_Name (Source : Name_Id) return String; + -- Returns the tree file name corresponding to Source + + function In_Extension_Chain + (Of_Project : Project_Id; + Prj : Project_Id) return Boolean; + -- Returns True iff Prj is an extension of Of_Project or if Of_Project is + -- an extension of Prj. + + procedure Usage; + -- Display the usage. + -- If called several times, the usage is displayed only the first time. + + -------------------- + -- Add_Object_Dir -- + -------------------- + + procedure Add_Object_Dir (N : String) is + begin + Add_Lib_Search_Dir (N); + + if Opt.Verbose_Mode then + Put ("Adding object directory """); + Put (N); + Put ("""."); + New_Line; + end if; + end Add_Object_Dir; + + -------------------- + -- Add_Source_Dir -- + -------------------- + + procedure Add_Source_Dir (N : String) is + begin + Add_Src_Search_Dir (N); + + if Opt.Verbose_Mode then + Put ("Adding source directory """); + Put (N); + Put ("""."); + New_Line; + end if; + end Add_Source_Dir; + + ------------------- + -- ALI_File_Name -- + ------------------- + + function ALI_File_Name (Source : Name_Id) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If the source name has an extension, then replace it with + -- the ALI suffix. + + for Index in reverse Src'First + 1 .. Src'Last loop + if Src (Index) = '.' then + return Src (Src'First .. Index - 1) & ALI_Suffix; + end if; + end loop; + + -- If there is no dot, or if it is the first character, just add the + -- ALI suffix. + + return Src & ALI_Suffix; + end ALI_File_Name; + + ------------------------ + -- Assembly_File_Name -- + ------------------------ + + function Assembly_File_Name (Source : Name_Id) 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_Directory -- + --------------------- + + procedure Clean_Directory (Dir : Name_Id) is + Directory : constant String := Get_Name_String (Dir); + Current : constant Dir_Name_Str := Get_Current_Dir; + + Direc : Dir_Type; + + Name : String (1 .. 200); + Last : Natural; + + procedure Set_Writable (Name : System.Address); + pragma Import (C, Set_Writable, "__gnat_set_writable"); + + begin + Change_Dir (Directory); + Open (Direc, "."); + + -- For each regular file in the directory, if switch -n has not been + -- specified, make it writable and delete the file. + + loop + Read (Direc, Name, Last); + exit when Last = 0; + + if Is_Regular_File (Name (1 .. Last)) then + if not Do_Nothing then + Name (Last + 1) := ASCII.NUL; + Set_Writable (Name (1)'Address); + end if; + + Delete (Directory, Name (1 .. Last)); + end if; + end loop; + + Close (Direc); + + -- Restore the initial working directory + + Change_Dir (Current); + end Clean_Directory; + + ----------------------- + -- Clean_Executables -- + ----------------------- + + procedure Clean_Executables is + Main_Source_File : File_Name_Type; + -- Current main source + + Source_File : File_Name_Type; + -- Current source file + + Full_Source_File : File_Name_Type; + -- Full name of the current source file + + Lib_File : File_Name_Type; + -- Current library file + + Full_Lib_File : File_Name_Type; + -- Full name of the current library file + + Text : Text_Buffer_Ptr; + The_ALI : ALI_Id; + + begin + Init_Q; + + -- 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; + Insert_Q (Main_Source_File); + + while not Empty_Q loop + Sources.Set_Last (0); + Extract_From_Q (Source_File); + Full_Source_File := Osint.Full_Source_Name (Source_File); + Lib_File := Osint.Lib_File_Name (Source_File); + Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); + + -- If we have an 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, Ignore_ED => False, 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 + Insert_Q (Withs.Table (K).Sfile); + 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 the 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 Name_Id := Strip_Suffix (Main_Source_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; + + ------------------- + -- Clean_Project -- + ------------------- + + procedure Clean_Project (Project : Project_Id) is + Main_Source_File : File_Name_Type; + -- Name of the executable on the command line, without directory + -- information. + + Executable : Name_Id; + -- Name of the executable file + + Current_Dir : constant Dir_Name_Str := Get_Current_Dir; + Data : constant Project_Data := Projects.Table (Project); + U_Data : Prj.Com.Unit_Data; + File_Name1 : Name_Id; + File_Name2 : Name_Id; + + use Prj.Com; + + begin + -- Check that we don't specify executable on the command line for + -- a main library project. + + if Project = Main_Project + and then Osint.Number_Of_Files /= 0 + and then Data.Library + then + Osint.Fail + ("Cannot specify executable(s) for a Library Project File"); + end if; + + if Verbose_Mode then + Put ("Cleaning project """); + Put (Get_Name_String (Data.Name)); + Put_Line (""""); + end if; + + -- Add project to the list of proceesed projects + + Processed_Projects.Increment_Last; + Processed_Projects.Table (Processed_Projects.Last) := Project; + + if Data.Object_Directory /= No_Name then + declare + Obj_Dir : constant String := + Get_Name_String (Data.Object_Directory); + + begin + Change_Dir (Obj_Dir); + + -- Look through the units to find those that are either immediate + -- sources or inherited sources of the project. + + for Unit in 1 .. Prj.Com.Units.Last loop + U_Data := Prj.Com.Units.Table (Unit); + File_Name1 := No_Name; + File_Name2 := No_Name; + + -- If either the spec or the body is a source of the project, + -- check for the corresponding ALI file in the object + -- directory. + + if In_Extension_Chain + (U_Data.File_Names (Body_Part).Project, Project) + or else + In_Extension_Chain + (U_Data.File_Names (Specification).Project, Project) + then + File_Name1 := U_Data.File_Names (Body_Part).Name; + File_Name2 := U_Data.File_Names (Specification).Name; + + -- If there is no body file name, then there may be only a + -- spec. + + if File_Name1 = No_Name then + File_Name1 := File_Name2; + File_Name2 := No_Name; + end if; + end if; + + -- If there is either a spec or a body, look for files in the + -- object directory. + + if File_Name1 /= No_Name then + declare + Asm : constant String := Assembly_File_Name (File_Name1); + ALI : constant String := ALI_File_Name (File_Name1); + Obj : constant String := Object_File_Name (File_Name1); + Adt : constant String := Tree_File_Name (File_Name1); + Deb : constant String := Debug_File_Name (File_Name1); + Rep : constant String := Repinfo_File_Name (File_Name1); + Del : Boolean := True; + + begin + -- If the ALI file exists and is read-only, no file is + -- deleted. + + if Is_Regular_File (ALI) then + if Is_Writable_File (ALI) then + Delete (Obj_Dir, ALI); + + else + Del := False; + + if Verbose_Mode then + Put ('"'); + Put (Obj_Dir); + + if Obj_Dir (Obj_Dir'Last) /= Dir_Separator then + Put (Dir_Separator); + end if; + + Put (ALI); + Put_Line (""" is read-only"); + end if; + end if; + end if; + + if Del then + + -- Object file + + if Is_Regular_File (Obj) then + Delete (Obj_Dir, Obj); + end if; + + -- Assembly file + + if Is_Regular_File (Asm) then + Delete (Obj_Dir, Asm); + end if; + + -- Tree file + + if Is_Regular_File (Adt) then + Delete (Obj_Dir, Adt); + end if; + + -- First expanded source file + + if Is_Regular_File (Deb) then + Delete (Obj_Dir, Deb); + end if; + + -- Repinfo file + + if Is_Regular_File (Rep) then + Delete (Obj_Dir, Rep); + end if; + + -- Second expanded source file + + if File_Name2 /= No_Name then + declare + Deb : constant String := + Debug_File_Name (File_Name2); + Rep : constant String := + Repinfo_File_Name (File_Name2); + begin + if Is_Regular_File (Deb) then + Delete (Obj_Dir, Deb); + end if; + + if Is_Regular_File (Rep) then + Delete (Obj_Dir, Rep); + end if; + end; + end if; + end if; + end; + end if; + end loop; + + if Verbose_Mode then + New_Line; + end if; + end; + end if; + + -- If switch -r is specified, call Clean_Project recursively for the + -- imported projects and the project being extended. + + if All_Projects then + declare + Imported : Project_List := Data.Imported_Projects; + Element : Project_Element; + Process : Boolean; + + begin + -- For each imported project, call Clean_Project if the project + -- has not been processed already. + + while Imported /= Empty_Project_List loop + Element := Project_Lists.Table (Imported); + Imported := Element.Next; + Process := True; + + for + J in Processed_Projects.First .. Processed_Projects.Last + loop + if Element.Project = Processed_Projects.Table (J) then + Process := False; + exit; + end if; + end loop; + + if Process then + Clean_Project (Element.Project); + end if; + end loop; + + -- If this project extends another project, call Clean_Project for + -- the project being extended. It is guaranteed that it has not + -- called before, because no other project may import or extend + -- this project. + + if Data.Extends /= No_Project then + Clean_Project (Data.Extends); + end if; + end; + end if; + + -- If this is a library project, clean the library directory, the + -- interface copy dir and, for a Stand-Alone Library, the binder + -- generated files of the library. + + -- The directories are cleaned only if switch -c is not specified. + + if Data.Library then + if not Compile_Only then + Clean_Directory (Data.Library_Dir); + + if Data.Library_Src_Dir /= No_Name + and then Data.Library_Src_Dir /= Data.Library_Dir + then + Clean_Directory (Data.Library_Src_Dir); + end if; + end if; + + if Data.Standalone_Library and then + Data.Object_Directory /= No_Name + then + Delete_Binder_Generated_Files + (Get_Name_String (Data.Object_Directory), Data.Library_Name); + end if; + + -- Otherwise, for the main project, delete the executables and the + -- binder generated files. + + -- The executables are deleted only if switch -c is not specified. + + elsif Project = Main_Project and then Data.Exec_Directory /= No_Name then + declare + Exec_Dir : constant String := + Get_Name_String (Data.Exec_Directory); + begin + Change_Dir (Exec_Dir); + + for N_File in 1 .. Osint.Number_Of_Files loop + Main_Source_File := Next_Main_Source; + + if not Compile_Only then + Executable := Executable_Of (Main_Project, Main_Source_File); + + if Is_Regular_File (Get_Name_String (Executable)) then + Delete (Exec_Dir, Get_Name_String (Executable)); + end if; + end if; + + if Data.Object_Directory /= No_Name then + Delete_Binder_Generated_Files + (Get_Name_String + (Data.Object_Directory), + Strip_Suffix (Main_Source_File)); + end if; + end loop; + end; + end if; + + -- Change back to previous directory + + Change_Dir (Current_Dir); + end Clean_Project; + + --------------------- + -- Debug_File_Name -- + --------------------- + + function Debug_File_Name (Source : Name_Id) 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 + + else + Delete_File (Full_Name (1 .. Last), Success); + + if not Success then + Put ("Warning: """); + Put (Full_Name (1 .. Last)); + Put_Line (""" could not be deleted"); + + elsif Verbose_Mode or else not Quiet_Output then + Put (""""); + Put (Full_Name (1 .. Last)); + Put_Line (""" has been deleted"); + end if; + end if; + end Delete; + + ----------------------------------- + -- Delete_Binder_Generated_Files -- + ----------------------------------- + + procedure Delete_Binder_Generated_Files (Dir : String; Source : Name_Id) 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; + Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String + & " Copyright 2003 Free Software Foundation, Inc."); + end if; + end Display_Copyright; + + ------------- + -- Empty_Q -- + ------------- + + function Empty_Q return Boolean is + begin + return Q_Front >= Q.Last; + end Empty_Q; + + -------------------- + -- Extract_From_Q -- + -------------------- + + procedure Extract_From_Q (Source_File : out File_Name_Type) is + File : constant File_Name_Type := Q.Table (Q_Front); + + begin + Q_Front := Q_Front + 1; + Source_File := File; + end Extract_From_Q; + + --------------- + -- Gnatclean -- + --------------- + + procedure Gnatclean is + begin + -- Do the necessary initializations + + Initialize; + + -- Parse the command line, getting the switches and the executable names + + Parse_Cmd_Line; + + if Verbose_Mode then + Display_Copyright; + end if; + + if Project_File_Name /= null then + + -- A project file was specified by a -P switch + + if Opt.Verbose_Mode then + New_Line; + Put ("Parsing Project File """); + Put (Project_File_Name.all); + Put_Line ("""."); + New_Line; + end if; + + -- Set the project parsing verbosity to whatever was specified + -- by a possible -vP switch. + + Prj.Pars.Set_Verbosity (To => Prj.Com.Current_Verbosity); + + -- Parse the project file. + -- If there is an error, Main_Project will still be No_Project. + + Prj.Pars.Parse + (Project => Main_Project, + Project_File_Name => Project_File_Name.all, + Packages_To_Check => Packages_To_Check_By_Gnatmake); + + if Main_Project = No_Project then + Fail ("""" & Project_File_Name.all & + """ processing failed"); + end if; + + if Opt.Verbose_Mode then + New_Line; + Put ("Parsing of Project File """); + Put (Project_File_Name.all); + Put (""" is finished."); + New_Line; + end if; + + -- We add the source directories and the object directories + -- to the search paths. + + Add_Source_Directories (Main_Project); + Add_Object_Directories (Main_Project); + + end if; + + Osint.Add_Default_Search_Dirs; + + -- If a project file was specified, but no executable name, put all + -- the mains of the project file (if any) as if there were on the + -- command line. + + if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then + declare + Value : String_List_Id := Projects.Table (Main_Project).Mains; + + begin + while Value /= Prj.Nil_String loop + Get_Name_String (String_Elements.Table (Value).Value); + Osint.Add_File (Name_Buffer (1 .. Name_Len)); + Value := String_Elements.Table (Value).Next; + end loop; + end; + end if; + + -- If neither a project file nor an executable were specified, + -- output the usage and exit. + + if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then + Usage; + return; + end if; + + if Verbose_Mode then + New_Line; + end if; + + if Main_Project /= No_Project then + + -- If a project file has been specified, call Clean_Project with the + -- project id of this project file, after resetting the list of + -- processed projects. + + Processed_Projects.Init; + Clean_Project (Main_Project); + + else + -- If no project file has been specified, the work is done in + -- Clean_Executables. + + Clean_Executables; + end if; + + -- 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; + + ------------------------ + -- In_Extension_Chain -- + ------------------------ + + function In_Extension_Chain + (Of_Project : Project_Id; + Prj : Project_Id) return Boolean + is + Data : Project_Data; + + begin + if Of_Project = Prj then + return True; + end if; + + Data := Projects.Table (Of_Project); + + while Data.Extends /= No_Project loop + if Data.Extends = Prj then + return True; + end if; + + Data := Projects.Table (Data.Extends); + end loop; + + Data := Projects.Table (Prj); + + while Data.Extends /= No_Project loop + if Data.Extends = Of_Project then + return True; + end if; + + Data := Projects.Table (Data.Extends); + end loop; + + return False; + end In_Extension_Chain; + + ------------ + -- Init_Q -- + ------------ + + procedure Init_Q is + begin + Q_Front := Q.First; + Q.Set_Last (Q.First); + end Init_Q; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if not Initialized then + Initialized := True; + + -- Initialize some packages + + Csets.Initialize; + Namet.Initialize; + Snames.Initialize; + Prj.Initialize; + end if; + + -- Reset global variables + + Free (Object_Directory_Path); + Do_Nothing := False; + File_Deleted := False; + Copyright_Displayed := False; + Usage_Displayed := False; + Free (Project_File_Name); + Main_Project := Prj.No_Project; + All_Projects := False; + end Initialize; + + -------------- + -- Insert_Q -- + -------------- + + procedure Insert_Q + (Source_File : File_Name_Type) + is + begin + -- Do not insert an empty name or an already marked source + + if Source_File /= No_Name + and then Get_Name_Table_Byte (Source_File) = 0 + then + Q.Table (Q.Last) := Source_File; + Q.Increment_Last; + + -- Mark the source that has been just added to the Q + + Set_Name_Table_Byte (Source_File, 1); + end if; + end Insert_Q; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (Source : Name_Id) 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 + begin + loop + case + GNAT.Command_Line.Getopt + ("aO: c D: F h I: I- n P: q r v vP0 vP1 vP2 X:") + is + when ASCII.NUL => + exit; + + when 'a' => + Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + + when 'c' => + Compile_Only := True; + + when 'D' => + declare + Dir : constant String := GNAT.Command_Line.Parameter; + + begin + if Object_Directory_Path /= null then + Fail ("duplicate -D switch"); + + elsif Project_File_Name /= null then + Fail ("-P and -D cannot be used simultaneously"); + + elsif not Is_Directory (Dir) then + Fail (Dir, " is not a directory"); + + else + Add_Lib_Search_Dir (Dir); + end if; + end; + + when 'F' => + Full_Path_Name_For_Brief_Errors := True; + + when 'h' => + Usage; + + when 'I' => + if Full_Switch = "I-" then + Opt.Look_In_Primary_Dir := False; + + else + Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + 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"); + + else + declare + Prj : constant String := GNAT.Command_Line.Parameter; + 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; + end if; + + when 'q' => + Quiet_Output := True; + + when 'r' => + All_Projects := True; + + when 'v' => + if Full_Switch = "v" then + Verbose_Mode := True; + + elsif Full_Switch = "vP0" then + Prj.Com.Current_Verbosity := Prj.Default; + + elsif Full_Switch = "vP1" then + Prj.Com.Current_Verbosity := Prj.Medium; + + else + Prj.Com.Current_Verbosity := Prj.High; + end if; + + when 'X' => + declare + Ext_Asgn : constant String := GNAT.Command_Line.Parameter; + Start : Positive := Ext_Asgn'First; + Stop : Natural := Ext_Asgn'Last; + Equal_Pos : Natural; + OK : Boolean := True; + + begin + if Ext_Asgn (Start) = '"' then + if Ext_Asgn (Stop) = '"' then + Start := Start + 1; + Stop := Stop - 1; + + else + OK := False; + end if; + end if; + + Equal_Pos := Start; + + while Equal_Pos <= Stop and then + Ext_Asgn (Equal_Pos) /= '=' + loop + Equal_Pos := Equal_Pos + 1; + end loop; + + if Equal_Pos = Start or else Equal_Pos > Stop then + OK := False; + end if; + + if OK then + Prj.Ext.Add + (External_Name => Ext_Asgn (Start .. Equal_Pos - 1), + Value => Ext_Asgn (Equal_Pos + 1 .. Stop)); + + else + Fail ("illegal external assignment '", Ext_Asgn, "'"); + end if; + end; + + when others => + Fail ("INTERNAL ERROR, please report"); + end case; + end loop; + + -- Get the file names + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + Add_File (S); + end; + end loop; + + exception + when GNAT.Command_Line.Invalid_Switch => + Usage; + Fail ("invalid switch : "& GNAT.Command_Line.Full_Switch); + + when GNAT.Command_Line.Invalid_Parameter => + Usage; + Fail ("parameter missing for : " & GNAT.Command_Line.Full_Switch); + end Parse_Cmd_Line; + + ----------------------- + -- Repinfo_File_Name -- + ----------------------- + + function Repinfo_File_Name (Source : Name_Id) return String is + begin + return Get_Name_String (Source) & Repinfo_Suffix; + end Repinfo_File_Name; + + -------------------- + -- Tree_File_Name -- + -------------------- + + function Tree_File_Name (Source : Name_Id) return String is + Src : constant String := Get_Name_String (Source); + + begin + -- If the 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] names"); + New_Line; + + 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<project> is specified"); + New_Line; + + Put_Line (" -c Only delete compiler generated files"); + Put_Line (" -D dir Specify dir as the object library"); + Put_Line (" -F Full project path name " & + "in brief error messages"); + Put_Line (" -h Display this message"); + 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 (" -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; + +begin + if Hostparm.OpenVMS then + Debug_Suffix (Debug_Suffix'First) := '_'; + Repinfo_Suffix (Repinfo_Suffix'First) := '_'; + B_Start (B_Start'Last) := '$'; + end if; +end Clean; |