mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-27 04:29:39 +00:00
1000 lines
33 KiB
Ada
1000 lines
33 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- C L E A N --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2003-2019, 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~<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 : 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, 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
|
|
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<project> 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;
|