Skip to content

R
riscv-gcc-1
Commit 53a0bb66 by Vincent Celier Committed by Arnaud Charlet
Options

gnatcmd.adb (GNATCmd): Accept switch -aP for commands that accept switch -P 

2007-04-20  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb (GNATCmd): Accept switch -aP for commands that accept
	switch -P
	(ASIS_Main): New global variable
	(Get_Closure): New procedure
	(GNATCmd): Set ASIS_Main when -P and -U with a main is used for gnat
	check, metric or pretty. Call Get_Closure in this case.
	(Check_Files): For GNAT LIST, check all sources of all projects when
	All_Projects is True.
	(GNATCmd): Accept -U for GNAT LIST

From-SVN: r125416
parent f38df0e1
Showing with 198 additions and 20 deletions
gcc/ada/gnatcmd.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2007, 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- --
......@@ -42,6 +42,7 @@ with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Table;
with Tempdir;
with Types; use Types;
with Hostparm; use Hostparm;
-- Used to determine if we are in VMS or not for error message purposes
......@@ -65,16 +66,18 @@ procedure GNATCmd is
-- Prefix of binder generated file, changed to b__ for VMS
Old_Project_File_Used : Boolean := False;
-- This flag indicates a switch -p (for gnatxref and gnatfind) for
-- an old fashioned project file. -p cannot be used in conjonction
-- with -P.
-- This flag indicates a switch -p (for gnatxref and gnatfind) for an old
-- fashioned project file. -p cannot be used in conjonction with -P.
Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary
Temp_File_Name : String_Access := null;
-- The name of the temporary text file to put a list of source/object
-- files to pass to a tool, when there are more than
-- Max_Files_On_The_Command_Line files.
-- files to pass to a tool, when the number of files exceeds the value of
-- Max_Files_On_The_Command_Line.
ASIS_Main : String_Access := null;
-- Main for commands Check, Metric and Pretty, when -U is used
package First_Switches is new Table.Table
(Table_Component_Type => String_Access,
......@@ -226,6 +229,10 @@ procedure GNATCmd is
procedure Delete_Temp_Config_Files;
-- Delete all temporary config files
procedure Get_Closure;
-- Get the sources in the closure of the ASIS_Main and add them to the
-- list of arguments.
function Index (Char : Character; Str : String) return Natural;
-- Returns first occurrence of Char in Str, returns 0 if Char not in Str
......@@ -386,17 +393,17 @@ procedure GNATCmd is
if The_Command = List then
if
Unit_Data.File_Names (Body_Part).Name /= No_Name
Unit_Data.File_Names (Body_Part).Name /= No_File
then
-- There is a body, check if it is for this project
if Unit_Data.File_Names (Body_Part).Project =
Project
if All_Projects or else
Unit_Data.File_Names (Body_Part).Project = Project
then
Subunit := False;
if Unit_Data.File_Names (Specification).Name =
No_Name
No_File
then
-- We have a body with no spec: we need to check if
-- this is a subunit, because gnatls will complain
......@@ -428,13 +435,13 @@ procedure GNATCmd is
end if;
elsif
Unit_Data.File_Names (Specification).Name /= No_Name
Unit_Data.File_Names (Specification).Name /= No_File
then
-- We have a spec with no body; check if it is for this
-- project.
if Unit_Data.File_Names (Specification).Project =
Project
if All_Projects or else
Unit_Data.File_Names (Specification).Project = Project
then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
......@@ -452,7 +459,7 @@ procedure GNATCmd is
elsif The_Command = Stack then
if
Unit_Data.File_Names (Body_Part).Name /= No_Name
Unit_Data.File_Names (Body_Part).Name /= No_File
then
-- There is a body. Check if .ci files for this project
-- must be added.
......@@ -464,7 +471,7 @@ procedure GNATCmd is
Subunit := False;
if
Unit_Data.File_Names (Specification).Name = No_Name
Unit_Data.File_Names (Specification).Name = No_File
then
-- We have a body with no spec: we need to check
-- if this is a subunit, because .ci files are not
......@@ -502,7 +509,7 @@ procedure GNATCmd is
end if;
elsif
Unit_Data.File_Names (Specification).Name /= No_Name
Unit_Data.File_Names (Specification).Name /= No_File
then
-- We have a spec with no body. Check if it is for this
-- project.
......@@ -684,7 +691,7 @@ procedure GNATCmd is
begin
Prj.Env.Create_Config_Pragmas_File
(Project, Project, Project_Tree, Include_Config_Files => False);
return Project_Tree.Projects.Table (Project).Config_File_Name;
return Name_Id (Project_Tree.Projects.Table (Project).Config_File_Name);
end Configuration_Pragmas_File;
------------------------------
......@@ -730,6 +737,147 @@ procedure GNATCmd is
end if;
end Delete_Temp_Config_Files;
-----------------
-- Get_Closure --
-----------------
procedure Get_Closure is
Args : constant Argument_List :=
(1 => new String'("-q"),
2 => new String'("-b"),
3 => new String'("-P"),
4 => Project_File,
5 => ASIS_Main,
6 => new String'("-bargs"),
7 => new String'("-R"),
8 => new String'("-Z"));
-- Arguments of the invocation of gnatmake to get the list of
FD : File_Descriptor;
-- File descriptor for the temp file that will get the output of the
-- invocation of gnatmake.
Name : Path_Name_Type;
-- Path of the file FD
GN_Name : constant String := Program_Name ("gnatmake").all;
-- Name for gnatmake
GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
-- Path of gnatmake
Return_Code : Integer;
Unused : Boolean;
pragma Warnings (Off, Unused);
File : Ada.Text_IO.File_Type;
Line : String (1 .. 250);
Last : Natural;
Udata : Unit_Data;
Path : File_Name_Type;
begin
if GN_Path = null then
Put_Line (Standard_Error, "could not locate " & GN_Name);
raise Error_Exit;
end if;
-- Create the temp file
Tempdir.Create_Temp_File (FD, Name);
-- And close it, because on VMS Spawn with a file descriptor created
-- with Create_Temp_File does not redirect output.
Close (FD);
-- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
Spawn
(Program_Name => GN_Path.all,
Args => Args,
Output_File => Get_Name_String (Name),
Success => Unused,
Return_Code => Return_Code,
Err_To_Out => True);
Close (FD);
-- Read the output of the invocation of gnatmake
Open (File, In_File, Get_Name_String (Name));
-- If it was unsuccessful, display the first line in the file and exit
-- with error.
if Return_Code /= 0 then
Get_Line (File, Line, Last);
if not Keep_Temporary_Files then
Delete (File);
else
Close (File);
end if;
Put_Line (Standard_Error, Line (1 .. Last));
Put_Line
(Standard_Error, "could not get closure of " & ASIS_Main.all);
raise Error_Exit;
else
-- Get each file name in the file, find its path and add it the the
-- list of arguments.
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
Path := No_File;
for Unit in Unit_Table.First ..
Unit_Table.Last (Project_Tree.Units)
loop
Udata := Project_Tree.Units.Table (Unit);
if Udata.File_Names (Specification).Name /= No_File
and then
Get_Name_String (Udata.File_Names (Specification).Name) =
Line (1 .. Last)
then
Path := Udata.File_Names (Specification).Path;
exit;
elsif Udata.File_Names (Body_Part).Name /= No_File
and then
Get_Name_String (Udata.File_Names (Body_Part).Name) =
Line (1 .. Last)
then
Path := Udata.File_Names (Body_Part).Path;
exit;
end if;
end loop;
Last_Switches.Increment_Last;
if Path /= No_File then
Last_Switches.Table (Last_Switches.Last) :=
new String'(Get_Name_String (Path));
else
Last_Switches.Table (Last_Switches.Last) :=
new String'(Line (1 .. Last));
end if;
end loop;
if not Keep_Temporary_Files then
Delete (File);
else
Close (File);
end if;
end if;
end Get_Closure;
-----------
-- Index --
-----------
......@@ -1493,9 +1641,19 @@ begin
end if;
end if;
-- -aPdir Add dir to the project search path
if Argv'Length > 3
and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
then
Add_Search_Project_Directory
(Argv (Argv'First + 3 .. Argv'Last));
Remove_Switch (Arg_Num);
-- -vPx Specify verbosity while parsing project files
if Argv'Length = 4
elsif Argv'Length = 4
and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
then
case Argv (Argv'Last) is
......@@ -1591,7 +1749,8 @@ begin
(The_Command = Check or else
The_Command = Pretty or else
The_Command = Metric or else
The_Command = Stack)
The_Command = Stack or else
The_Command = List)
and then Argv'Length = 2
and then Argv (2) = 'U'
then
......@@ -1602,6 +1761,19 @@ begin
Arg_Num := Arg_Num + 1;
end if;
elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
or else The_Command = Metric
or else The_Command = Pretty)
and then Project_File /= null
and then All_Projects
then
if ASIS_Main /= null then
Fail ("cannot specify more than one main after -U");
else
ASIS_Main := Argv;
Remove_Switch (Arg_Num);
end if;
else
Arg_Num := Arg_Num + 1;
end if;
......@@ -2040,11 +2212,17 @@ begin
end;
end if;
-- For gnat check, metric or pretty with -U + a main, get the list
-- of sources from the closure and add them to the arguments.
if ASIS_Main /= null then
Get_Closure;
-- For gnat check, gnat pretty, gnat metric, gnat list, and gnat
-- stack, if no file has been put on the command line, call tool
-- with all the sources of the main project.
if The_Command = Check or else
elsif The_Command = Check or else
The_Command = Pretty or else
The_Command = Metric or else
The_Command = List or else
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment