----------------------------------
The_Command : Command_Type;
+ -- The command specified in the invocation of the GNAT driver
Command_Arg : Positive := 1;
+ -- The index of the command in the arguments of the GNAT driver
My_Exit_Status : Exit_Status := Success;
+ -- The exit status of the spawned tool. Used to set the correct VMS
+ -- exit status.
Current_Work_Dir : constant String := Get_Current_Dir;
+ -- The path of the working directory
+
+ All_Projects : Boolean := False;
+ -- Flag used for GNAT PRETTY and GNAT METRIC to indicate that
+ -- the underlying tool (gnatpp or gnatmetric) should be invoked for all
+ -- sources of all projects.
-----------------------
-- Local Subprograms --
else
-- For gnatpp and gnatmetric, put all sources
- -- of the project.
+ -- of the project, or of all projects if -U was specified.
for Kind in Spec_Or_Body loop
Root_Project : Project_Id) return Boolean
is
begin
- if Project = Root_Project then
+ if Project = No_Project then
+ return False;
+
+ elsif All_Projects or Project = Root_Project then
return True;
elsif The_Command = Metric then
Remove_Switch (Arg_Num);
+ elsif (The_Command = Pretty or else The_Command = Metric)
+ and then Argv'Length = 2
+ and then Argv (2) = 'U'
+ then
+ All_Projects := True;
+ Remove_Switch (Arg_Num);
+
else
Arg_Num := Arg_Num + 1;
end if;
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
new String'("-C" & Get_Name_String (CP_File));
+
else
Add_To_Carg_Switches
(new String'("-gnatec=" & Get_Name_String (CP_File)));
--------------------------------
procedure Change_To_Object_Directory (Project : Project_Id) is
+ Actual_Project : Project_Id;
+
begin
- -- Nothing to do if the current working directory is alresdy the one
- -- we want.
+ -- For sources outside of any project, compilation occurs in the object
+ -- directory of the main project, otherwise we use the project given.
+
+ if Project = No_Project then
+ Actual_Project := Main_Project;
+ else
+ Actual_Project := Project;
+ end if;
- if Project_Object_Directory /= Project then
- Project_Object_Directory := Project;
+ -- Nothing to do if the current working directory is already the correct
+ -- object directory.
- -- If in a real project, set the working directory to the object
- -- directory of the project.
+ if Project_Object_Directory /= Actual_Project then
+ Project_Object_Directory := Actual_Project;
- if Project /= No_Project then
- Change_Dir
- (Get_Name_String
- (Project_Tree.Projects.Table
- (Project).Object_Directory));
+ -- Set the working directory to the object directory of the actual
+ -- project.
- -- Otherwise, for sources outside of any project, set the working
- -- directory to the object directory of the main project.
+ Change_Dir
+ (Get_Name_String
+ (Project_Tree.Projects.Table
+ (Actual_Project).Object_Directory));
- elsif Main_Project /= No_Project then
- Change_Dir
- (Get_Name_String
- (Project_Tree.Projects.Table
- (Main_Project).Object_Directory));
- end if;
end if;
+
+ exception
+ -- Fail if unable to change to the object directory
+
+ when Directory_Error =>
+ Make_Failed ("unable to change to object directory of project " &
+ Get_Name_String (Project_Tree.Projects.Table
+ (Actual_Project).Display_Name));
end Change_To_Object_Directory;
-----------
declare
New_Args : Argument_List (1 .. Number);
+ Last_New : Natural := 0;
begin
Current := Switches.Values;
Element := Project_Tree.String_Elements.
Table (Current);
Get_Name_String (Element.Value);
- New_Args (Index) :=
- new String'(Name_Buffer (1 .. Name_Len));
- Test_If_Relative_Path
- (New_Args (Index), Parent => Data.Dir_Path);
+
+ if Name_Len > 0 then
+ Last_New := Last_New + 1;
+ New_Args (Last_New) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ Test_If_Relative_Path
+ (New_Args (Last_New),
+ Parent => Data.Dir_Path);
+ end if;
+
Current := Element.Next;
end loop;
Add_Arguments
(Configuration_Pragmas_Switch
(Arguments_Project) &
- New_Args & The_Saved_Gcc_Switches.all);
+ New_Args (1 .. Last_New) &
+ The_Saved_Gcc_Switches.all);
end;
end;
Comp_Args : Argument_List (Args'First .. Args'Last + 9);
Comp_Next : Integer := Args'First;
Comp_Last : Integer;
+ Arg_Index : Integer;
function Ada_File_Name (Name : Name_Id) return Boolean;
-- Returns True if Name is the name of an ada source file
and then S = Strip_Directory (S)
then
Comp_Last := Comp_Next + Args'Length - 3;
- Comp_Args (Comp_Next .. Comp_Last) :=
- Args (Args'First + 1 .. Args'Last - 1);
+ Arg_Index := Args'First + 1;
else
Comp_Last := Comp_Next + Args'Length - 1;
- Comp_Args (Comp_Next .. Comp_Last) := Args;
+ Arg_Index := Args'First;
end if;
+ -- Make a deep copy of the arguments, because Normalize_Arguments
+ -- may deallocate some arguments.
+
+ for J in Comp_Next .. Comp_Last loop
+ Comp_Args (J) := new String'(Args (Arg_Index).all);
+ Arg_Index := Arg_Index + 1;
+ end loop;
+
-- Set -gnatpg for predefined files (for this purpose the renamings
-- such as Text_IO do not count as predefined). Note that we strip
-- the directory name from the source file name becase the call to
then
-- Change current directory to object directory of main project
- begin
- Project_Object_Directory := No_Project;
- Change_To_Object_Directory (Main_Project);
-
- exception
- when Directory_Error =>
-
- -- This should never happen. But, if it does, display the
- -- content of the parent directory of the obj dir.
-
- declare
- Parent : constant Dir_Name_Str :=
- Dir_Name
- (Get_Name_String
- (Project_Tree.Projects.Table
- (Main_Project).Object_Directory));
-
- Dir : Dir_Type;
- Str : String (1 .. 200);
- Last : Natural;
-
- begin
- Write_Str ("Contents of directory """);
- Write_Str (Parent);
- Write_Line (""":");
-
- Open (Dir, Parent);
-
- loop
- Read (Dir, Str, Last);
- exit when Last = 0;
- Write_Str (" ");
- Write_Line (Str (1 .. Last));
- end loop;
-
- Close (Dir);
-
- exception
- when X : others =>
- Write_Line ("(unexpected exception)");
- Write_Line (Exception_Information (X));
-
- if Is_Open (Dir) then
- Close (Dir);
- end if;
- end;
-
- Make_Failed
- ("unable to change working directory to """,
- Get_Name_String
- (Project_Tree.Projects.Table
- (Main_Project).Object_Directory),
- """");
- end;
+ Project_Object_Directory := No_Project;
+ Change_To_Object_Directory (Main_Project);
end if;
-- Source file lookups should be cached for efficiency.
begin
if not Is_Absolute_Path (Exec_File_Name) then
- for Index in Exec_File_Name'Range loop
- if Exec_File_Name (Index) = Directory_Separator then
- Make_Failed ("relative executable (""",
- Exec_File_Name,
- """) with directory part not " &
- "allowed when using project files");
- end if;
- end loop;
-
Get_Name_String
(Project_Tree.Projects.Table
(Main_Project).Exec_Directory);
begin
if not Is_Absolute_Path (Exec_File_Name) then
- for Index in Exec_File_Name'Range loop
- if Exec_File_Name (Index) = Directory_Separator then
- Make_Failed ("relative executable (""",
- Exec_File_Name,
- """) with directory part not " &
- "allowed when using project files");
- end if;
- end loop;
Get_Name_String (Project_Tree.Projects.Table
- (Main_Project).Exec_Directory);
+ (Main_Project).Exec_Directory);
if
Name_Buffer (Name_Len) /= Directory_Separator
Name_Len := Name_Len + Exec_File_Name'Length;
Executable := Name_Find;
- Non_Std_Executable := True;
end if;
+
+ Non_Std_Executable := True;
end;
end if;
OSDN Git Service
