------------------------------------------------------------------------------
-- --
-- GPR TECHNOLOGY --
-- --
-- Copyright (C) 2015-2021, AdaCore --
-- --
-- This 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. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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, --
-- see . --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers.Generic_Sort;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GPR.Conf; use GPR.Conf;
with GPR.Env; use GPR.Env;
with GPR.Names; use GPR.Names;
with GPR.Osint;
with GPR.Snames;
with GPR.Tree;
with GPR.Util; use GPR.Util;
with Gpr_Build_Util; use Gpr_Build_Util;
procedure Gprls.Main is
use GPR;
File_Set : Boolean := False;
-- Set to True by -P switch.
-- Used to detect multiple -P switches.
Print_Usage : Boolean := False;
-- Set to True with switch -h
Project_File_Name_Expected : Boolean := False;
-- True when switch "-P" has just been scanned
Search_Project_Dir_Expected : Boolean := False;
-- True when last switch was -aP
Path_Name : String_Access;
Path_Last : Natural;
Output_Name : String_Access;
User_Project_Node : Project_Node_Id;
No_Project_File_Specified : Boolean := False;
All_Projects : Boolean := False;
procedure Initialize;
procedure Scan_Arg (Argv : String);
-- Scan and process user specific arguments (Argv is a single argument)
procedure Usage;
-- Print usage message
procedure Display_Closures;
-- Display output when switch --closure is used
procedure Display_Output;
-- Display output when switch --closure is not used
procedure Display_Paths;
-- Display source, object and project paths
procedure Get_Source_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths);
procedure Get_All_Source_Dirs is
new For_Every_Project_Imported (Paths, Get_Source_Dirs);
procedure Get_Object_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths);
procedure Get_All_Object_Dirs is
new For_Every_Project_Imported (Paths, Get_Object_Dirs);
procedure Get_Runtime_Object_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths);
procedure Get_All_Runtime_Object_Dirs is
new For_Every_Project_Imported (Paths, Get_Runtime_Object_Dirs);
procedure Look_For_Sources;
-- Get the source ids
subtype One_Range is Integer range -1 .. 1;
function Compare (Left, Right : String) return One_Range is
(if Left > Right then 1 elsif Left = Right then 0 else -1);
function Get_Tree_Name (Index : Positive) return String;
-- Get main project name of the source taken by Index from File_Names
-- container.
function Before (Left, Right : Positive) return Boolean
is
(case Compare (Get_Tree_Name (Left), Get_Tree_Name (Right)) is
when 1 => False,
when -1 => True,
when 0 =>
(case Compare
(File_Names (Left).File_Name, File_Names (Right).File_Name)
is
when 1 => False,
when -1 => True,
when 0 => File_Names (Left).Source.Path.Display_Name
< File_Names (Right).Source.Path.Display_Name));
-- Returns True if element of the File_Names in Left position have to be
-- before the element in Right position.
procedure Swap_File_Names (Left, Right : Positive);
-- Swap 2 elements in File_Names vector
procedure Do_List (Project : Project_Id; Tree : Project_Tree_Ref);
-- Iterates over project or over aggregated projects to prepare the source
-- list to process.
procedure Sort_File_Names is new Ada.Containers.Generic_Sort
(Index_Type => Positive,
Before => Before,
Swap => Swap_File_Names);
-- Sort File_Names vector declared in the GPRls specification
----------------------
-- Display_Closures --
----------------------
procedure Display_Closures is
begin
if File_Names.Is_Empty then
Fail_Program (Project_Tree, "no main specified for closure");
else
declare
The_Sources : String_Vectors.Vector;
Result : String_Vectors.Vector;
Status : GPR.Util.Status_Type;
begin
for FN_Source of File_Names loop
if FN_Source.Source /= No_Source then
The_Sources.Append
(Get_Name_String (FN_Source.Source.File));
end if;
end loop;
if The_Sources.Is_Empty then
Finish_Program (Project_Tree);
end if;
Get_Closures
(Project => Main_Project,
In_Tree => Project_Tree,
Mains => The_Sources,
All_Projects => True,
Include_Externally_Built => True,
Status => Status,
Result => Result);
New_Line;
if Status = Incomplete_Closure then
if The_Sources.Last_Index = 1 then
Put_Line ("Incomplete closure:");
else
Put_Line ("Incomplete closures:");
end if;
elsif Status = GPR.Util.Success then
if The_Sources.Last_Index = 1 then
Put_Line ("Closure:");
else
Put_Line ("Closures:");
end if;
else
Fail_Program
(Project_Tree, "unable to get closures: " & Status'Img);
end if;
New_Line;
if not Result.Is_Empty then
for Res of Result loop
Put_Line (" " & Res);
end loop;
New_Line;
end if;
end;
end if;
end Display_Closures;
--------------------
-- Display_Output --
--------------------
procedure Display_Output is
begin
if Very_Verbose_Mode then
-- First the ALI files that are not found
for FN_Source of File_Names loop
if FN_Source.Source /= No_Source
and then FN_Source.The_ALI = No_ALI_Id
then
GNATDIST.Output_No_ALI (FN_Source);
end if;
end loop;
-- Then the ALI that have been found
for FN_Source of File_Names loop
if FN_Source.Source /= No_Source
and then FN_Source.The_ALI /= No_ALI_Id
then
GNATDIST.Output_ALI (FN_Source);
end if;
end loop;
else
for FN_Source of File_Names loop
declare
Id : ALI_Id;
Last_U : Unit_Id;
begin
if FN_Source.Source /= No_Source then
Id := FN_Source.The_ALI;
if Id = No_ALI_Id then
null;
else
Get_Name_String
(Units.Table (ALIs.Table (Id).First_Unit).Uname);
if Print_Object then
if ALIs.Table (Id).No_Object then
Output_Object (No_File);
else
Output_Object (ALIs.Table (Id).Ofile_Full_Name);
end if;
end if;
-- In verbose mode print all main units in the ALI file,
-- otherwise just print the first one to ease columnwise
-- printout.
if Verbose_Mode then
Last_U := ALIs.Table (Id).Last_Unit;
else
Last_U := ALIs.Table (Id).First_Unit;
end if;
for U in ALIs.Table (Id).First_Unit .. Last_U loop
if Print_Unit then
Output_Unit (U);
end if;
-- Output source now, unless if it will be done as
-- part of outputing dependencies.
if not (Dependable and then Print_Source) then
Output_Source
(FN_Source.Source,
Corresponding_Sdep_Entry (Id, U));
end if;
end loop;
-- Print out list of units on which this unit depends (D
-- lines).
if Dependable and then Print_Source then
if Verbose_Mode then
Put_Line (" depends upon");
end if;
for D in
ALIs.Table (Id).First_Sdep ..
ALIs.Table (Id).Last_Sdep
loop
if
not Is_Ada_Predefined_File_Name
(Sdep.Table (D).Sfile)
then
Put (" ");
Output_Source (FN_Source.Tree, D);
end if;
end loop;
end if;
end if;
end if;
end;
end loop;
end if;
end Display_Output;
-------------------
-- Display_Paths --
-------------------
procedure Display_Paths is
Source_Paths : Paths := No_Paths;
Object_Paths : Paths := No_Paths;
Path : Path_Access;
procedure Put_Path (Path : String);
-- Put path prefixed with 3 spaces to standard output add directory
-- separator at the end if absent.
--------------
-- Put_Path --
--------------
procedure Put_Path (Path : String) is
begin
if Path'Length > 1
and then Path (Path'Last - 1 .. Path'Last)
= (1 .. 2 => Directory_Separator)
then
Put_Path (Path (Path'First .. Path'Last - 1));
return;
end if;
Put (" ");
Put (Path);
if Path (Path'Last) /= Directory_Separator then
Put_Line ("" & Directory_Separator);
else
New_Line;
end if;
end Put_Path;
begin
New_Line;
Display_Version ("GPRLS", "2015");
New_Line;
Put_Line ("Source Search Path:");
-- First the source directories
Get_All_Source_Dirs (Main_Project, Project_Tree, Source_Paths);
-- Then the runtime source directories, if any
Get_All_Runtime_Source_Dirs (Main_Project, Project_Tree, Source_Paths);
Path := Source_Paths.First;
while Path /= null loop
Put_Path (Path.Path.all);
Path := Path.Next;
end loop;
New_Line;
Put_Line ("Object Search Path:");
-- First the object directories
Get_All_Object_Dirs (Main_Project, Project_Tree, Object_Paths);
-- Then the runtime library directories, if any
Get_All_Runtime_Object_Dirs (Main_Project, Project_Tree, Object_Paths);
Path := Object_Paths.First;
while Path /= null loop
Put_Path (Path.Path.all);
Path := Path.Next;
end loop;
New_Line;
Put_Line ("Project Search Path:");
declare
Path : String_Access;
First : Positive;
Last : Natural;
begin
Put_Line (" ");
GPR.Env.Get_Path (Root_Environment.Project_Path, Path);
if Path /= null then
First := Path'First;
while First < Path'Last loop
Last := First;
while Last < Path'Last and then
Path (Last + 1) /= Path_Separator
loop
Last := Last + 1;
end loop;
if Path (First .. Last) /= "." then
Put_Path (Path (First .. Last));
end if;
First := Last + 1;
while First < Path'Last and then
Path (First) = Path_Separator
loop
First := First + 1;
end loop;
end loop;
end if;
end;
New_Line;
end Display_Paths;
---------------------
-- Get_Object_Dirs --
---------------------
procedure Get_Object_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths)
is
pragma Unreferenced (Tree);
Name : Path_Name_Type := No_Path;
begin
case Project.Qualifier is
when Aggregate | Abstract_Project | Configuration =>
null;
when Library | Aggregate_Library =>
Name := Project.Library_ALI_Dir.Display_Name;
if Name = No_Path then
Name := Project.Library_Dir.Display_Name;
end if;
when Unspecified | GPR.Standard =>
Name := Project.Object_Directory.Display_Name;
end case;
if Name /= No_Path then
Add (Get_Name_String (Name), With_State);
end if;
end Get_Object_Dirs;
-----------------------------
-- Get_Runtime_Object_Dirs --
-----------------------------
procedure Get_Runtime_Object_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths)
is
List : Language_Ptr := Project.Languages;
Dirs : Name_List_Index;
Nam_Nod : Name_Node;
begin
while List /= No_Language_Index loop
Dirs := List.Config.Runtime_Library_Dirs;
while Dirs /= No_Name_List loop
Nam_Nod := Tree.Shared.Name_Lists.Table (Dirs);
Add (Get_Name_String (Nam_Nod.Name), With_State);
Dirs := Nam_Nod.Next;
end loop;
List := List.Next;
end loop;
end Get_Runtime_Object_Dirs;
---------------------
-- Get_Source_Dirs --
---------------------
procedure Get_Source_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Paths)
is
Source_Dirs : String_List_Id := Project.Source_Dirs;
begin
while Source_Dirs /= Nil_String loop
Add
(Get_Name_String
(Tree.Shared.String_Elements.Table (Source_Dirs).Display_Value),
With_State);
Source_Dirs := Tree.Shared.String_Elements.Table (Source_Dirs).Next;
end loop;
end Get_Source_Dirs;
-------------------
-- Get_Tree_Name --
-------------------
function Get_Tree_Name (Index : Positive) return String is
Tree : constant Project_Tree_Ref := File_Names (Index).Tree;
begin
if Tree = null then
return "";
else
return Get_Name_String (Tree.Projects.Project.Name);
end if;
end Get_Tree_Name;
----------------------
-- Look_For_Sources --
----------------------
procedure Look_For_Sources is
begin
for FN_Source of File_Names loop
if FN_Source.Source = No_Source then
Put_Line
(Standard_Error,
"Can't find source for " & FN_Source.File_Name);
elsif FN_Source.Source.Dep_Path = No_Path then
Put_Line
(Standard_Error,
"Can't find ALI file for "
& Get_Name_String (FN_Source.Source.Path.Display_Name));
else
declare
Text : Text_Buffer_Ptr;
Source : constant GPR.Source_Id := FN_Source.Source;
begin
Text := Osint.Read_Library_Info
(File_Name_Type (Source.Dep_Path));
-- If the ALI file cannot be found and the project is an
-- externally built library project, look for the ALI file
-- in the library directory.
if Text = null and then
Source.Project.Externally_Built and then
Source.Project.Library
then
declare
Dep_Path_Name : constant String :=
Get_Name_String (Source.Project.Library_Dir.Name) &
Directory_Separator &
Get_Name_String (Source.Dep_Name);
Dep_Path : File_Name_Type;
begin
Set_Name_Buffer (Dep_Path_Name);
Dep_Path := Name_Find;
Text := Osint.Read_Library_Info (Dep_Path);
end;
end if;
if Text /= null then
FN_Source.The_ALI := Scan_ALI
(F => File_Name_Type (Source.Dep_Path),
T => Text,
Ignore_ED => False,
Err => True,
Read_Lines => "WD",
Object_Path => File_Name_Type (Source.Object_Path));
Free (Text);
else
FN_Source.The_ALI := No_ALI_Id;
if Very_Verbose_Mode then
-- With switch -V, when the ALI file is not found, this
-- will be reported in the output later.
null;
else
Put_Line
(Standard_Error,
"Can't find ALI file for "
& Get_Name_String (Source.Path.Display_Name));
end if;
end if;
end;
end if;
end loop;
end Look_For_Sources;
--------------
-- Scan_Arg --
--------------
procedure Scan_Arg (Argv : String) is
FD : File_Descriptor;
Len : Integer;
OK : Boolean;
begin
pragma Assert (Argv'First = 1);
if Argv'Length = 0 then
return;
end if;
OK := True;
-- -P xxx
if Project_File_Name_Expected then
if Argv (1) = '-' then
Fail ("project file name missing");
else
File_Set := True;
Project_File_Name := new String'(Argv);
Project_File_Name_Expected := False;
end if;
-- -aP xxx
elsif Search_Project_Dir_Expected then
if Argv (1) = '-' then
Fail ("directory name missing after -aP");
else
Search_Project_Dir_Expected := False;
Add_Directories
(Root_Environment.Project_Path, Argv, Prepend => True);
end if;
elsif Argv (1) = '-' then
if Argv'Length = 1 then
Fail ("switch character '-' cannot be followed by a blank");
-- Forbid -?- or -??- where ? is any character
elsif (Argv'Length = 3 and then Argv (3) = '-')
or else (Argv'Length = 4 and then Argv (4) = '-')
then
Fail ("Trailing ""-"" at the end of " & Argv & " forbidden.");
-- Processing for -aP
elsif Argv'Length >= 3 and then Argv (1 .. 3) = "-aP" then
if Argv'Length = 3 then
Search_Project_Dir_Expected := True;
else
Add_Directories
(Root_Environment.Project_Path,
Argv (4 .. Argv'Last),
Prepend => True);
end if;
-- Processing for --unchecked-shared-lib-imports
elsif Argv = "--unchecked-shared-lib-imports" then
Opt.Unchecked_Shared_Lib_Imports := True;
elsif Argv = "--closure" then
Closure := True;
-- Processing for one character switches
elsif Argv'Length = 2 then
case Argv (2) is
when 'a' => null; -- ??? To be implemented
when 'h' => Print_Usage := True;
when 'u' => Reset_Print; Print_Unit := True;
when 'U' => All_Projects := True;
when 's' => Reset_Print; Print_Source := True;
when 'o' => Reset_Print; Print_Object := True;
when 'v' =>
Verbose_Mode := True;
Verbosity_Level := High;
when 'd' => Dependable := True;
when 'V' => Very_Verbose_Mode := True;
when 'P' =>
if File_Set then
Fail ("only one -P switch may be specified");
end if;
Project_File_Name_Expected := True;
when others => OK := False;
end case;
elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then
case Argv (4) is
when '0' => Current_Verbosity := Default;
when '1' => Current_Verbosity := Medium;
when '2' => Current_Verbosity := High;
when others => OK := False;
end case;
-- -Pxxx
elsif Argv'Length > 2 and then Argv (2) = 'P' then
if File_Set then
Fail ("only one -P switch may be specified");
end if;
File_Set := True;
Project_File_Name := new String'(Argv (3 .. Argv'Last));
-- Processing for -files=file
elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then
FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text);
if FD = Invalid_FD then
Osint.Fail ("could not find text file """ &
Argv (8 .. Argv'Last) & '"');
end if;
Len := Integer (File_Length (FD));
declare
Buffer : String (1 .. Len + 1);
Index : Positive := 1;
Last : Positive;
begin
-- Read the file
Len := Read (FD, Buffer (1)'Address, Len);
Buffer (Buffer'Last) := ASCII.NUL;
Close (FD);
-- Scan the file line by line
while Index < Buffer'Last loop
-- Find the end of line
Last := Index;
while Last <= Buffer'Last
and then Buffer (Last) /= ASCII.LF
and then Buffer (Last) /= ASCII.CR
loop
Last := Last + 1;
end loop;
-- Ignore empty lines
if Last > Index then
Add_File (Buffer (Index .. Last - 1), No_Project_Tree);
end if;
-- Find the beginning of the next line
Index := Last;
while Buffer (Index) = ASCII.CR or else
Buffer (Index) = ASCII.LF
loop
Index := Index + 1;
end loop;
end loop;
end;
elsif Argv'Length > Target_Project_Option'Length
and then
Argv (1 .. Target_Project_Option'Length) =
Target_Project_Option
then
if Target_Name /= null then
if Target_Name.all /=
Argv (Target_Project_Option'Length + 1
.. Argv'Last)
then
Fail_Program
(Project_Tree,
"several target switches "
& "cannot be specified");
end if;
else
Target_Name :=
new String'
(Argv (Target_Project_Option'Length + 1
.. Argv'Last));
end if;
-- Processing for --RTS=path
elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then
if Argv'Length <= 6 or else Argv (6) /= '='then
Osint.Fail ("missing path for --RTS");
else
-- Check that it is the first time we see this switch or, if
-- it is not the first time, the same path is specified.
if RTS_Specified = null then
RTS_Specified := new String'(Argv (7 .. Argv'Last));
Set_Runtime_For
(Snames.Name_Ada, Argv (7 .. Argv'Last));
elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then
Osint.Fail ("--RTS cannot be specified multiple times");
end if;
end if;
elsif Argv'Length >= 3
and then Argv (2) = 'X'
and then Is_External_Assignment (Root_Environment, Argv)
then
-- Is_External_Assignment has side effects when it returns True
null;
else
OK := False;
end if;
-- If not a switch, it must be a file name
else
Add_File (Argv, No_Project_Tree);
end if;
if not OK then
Put ("warning: unknown switch """);
Put (Argv);
Put_Line ("""");
end if;
end Scan_Arg;
---------------------
-- Swap_File_Names --
---------------------
procedure Swap_File_Names (Left, Right : Positive) is
begin
File_Names.Swap (Left, Right);
end Swap_File_Names;
-----------
-- Usage --
-----------
procedure Usage is
begin
-- Usage line
Put_Line ("Usage: gprls switches [list of object files]");
New_Line;
-- GPRLS switches
Put_Line ("switches:");
Display_Usage_Version_And_Help;
-- Line for -Pproj
Put_Line (" -Pproj Use project file proj");
-- Line for -a
Put_Line (" -a Also output relevant predefined units");
-- Line for -u
Put_Line (" -u Output only relevant unit names");
-- Line for -U
Put_Line (" -U List sources for all projects");
-- Line for -h
Put_Line (" -h Output this help message");
-- Line for -s
Put_Line (" -s Output only relevant source names");
-- Line for -o
Put_Line (" -o Output only relevant object names");
-- Line for -d
Put_Line (" -d Output sources on which specified units " &
"depend");
-- Line for -v
Put_Line (" -v Verbose output, full path and unit " &
"information");
-- Line for -vPx
Put_Line (" -vPx Specify verbosity when parsing project " &
"files (x = 0/1/2)");
-- Line for --closure
Put_Line (" --closure List paths of sources in closures of mains");
New_Line;
-- Line for -files=
Put_Line (" -files=fil Files are listed in text file 'fil'");
-- Line for -aP switch
Put_Line (" -aP dir Add directory dir to project search path");
-- Line for --target=
Put_Line (" --target=xxx Specify target xxx");
-- Line for --RTS
Put_Line (" --RTS=dir Specify the Ada runtime");
-- Line for --unchecked-shared-lib-imports
Put_Line (" --unchecked-shared-lib-imports");
Put_Line
(" Shared library projects may import any project");
-- Line for -X
Put_Line (" -Xnm=val Specify an external reference for " &
"project files");
-- File Status explanation
New_Line;
Put_Line (" File status can be:");
for ST in File_Status loop
Put (" ");
Output_Status (ST, Verbose => False);
Put (" ==> ");
Output_Status (ST, Verbose => True);
New_Line;
end loop;
end Usage;
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
procedure Initialize is
begin
if not Initialized then
Initialized := True;
-- Initialize some packages
Snames.Initialize;
Set_Program_Name ("gprls");
GPR.Tree.Initialize (Root_Environment, Gprls_Flags);
GPR.Tree.Initialize (Project_Node_Tree);
GPR.Initialize (Project_Tree);
GPR.Tree.Initialize (Tree);
end if;
end Initialize;
--------------
-- _Do_List --
--------------
procedure Do_List
(Project : Project_Id; Tree : Project_Tree_Ref)
is
Iter : Source_Iterator := For_Each_Source (Tree);
Source : GPR.Source_Id;
begin
loop
Source := Element (Iter);
exit when Source = No_Source;
Initialize_Source_Record (Source);
Next (Iter);
end loop;
if Closure and then No_Files_In_Command_Line then
-- Get the mains declared in the main project
declare
Mains : String_List_Id := Project.Mains;
Elem : String_Element;
begin
while Mains /= Nil_String loop
Elem := Tree.Shared.String_Elements.Table (Mains);
Add_File (Get_Name_String (Elem.Value), Tree);
Mains := Elem.Next;
end loop;
end;
end if;
if No_Files_In_Command_Line and not Closure then
-- Get all the compilable sources of the project
declare
Unit : GPR.Unit_Index;
Subunit : Boolean := False;
begin
Unit := Units_Htable.Get_First (Tree.Units_HT);
while Unit /= No_Unit_Index loop
-- We only need to put the library units, body or spec, but not
-- the subunits.
if Unit.File_Names (Impl) /= null
and then not Unit.File_Names (Impl).Locally_Removed
then
-- There is a body, check if it is for this project
if All_Projects
or else Unit.File_Names (Impl).Project = Project
then
Subunit := False;
if Unit.File_Names (Spec) = null
or else Unit.File_Names (Spec).Locally_Removed
then
-- We have a body with no spec: we need to check if
-- this is a subunit, because gnatls will complain
-- about subunits.
Subunit := Is_Subunit (Unit.File_Names (Impl));
end if;
if not Subunit then
Add_File
(Get_Name_String (Unit.File_Names (Impl).Object),
Tree,
Source => Unit.File_Names (Impl));
end if;
end if;
elsif Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed
and then
-- We have a spec with no body. Check if it is for this project
(All_Projects
or else Unit.File_Names (Spec).Project = Project)
then
Add_File
(Get_Name_String (Unit.File_Names (Spec).Object),
Tree,
Source => Unit.File_Names (Spec));
end if;
Unit := Units_Htable.Get_Next (Tree.Units_HT);
end loop;
end;
else
-- Find the sources in the project files
for FN_Source of File_Names loop
declare
File_Name : String renames FN_Source.File_Name;
Unit : GPR.Unit_Index;
Subunit : Boolean := False;
begin
Canonical_Case_File_Name (File_Name);
Unit := Units_Htable.Get_First (Tree.Units_HT);
Unit_Loop :
while Unit /= No_Unit_Index loop
-- We only need to put the library units, body or spec, but
-- not the subunits.
if Unit.File_Names (Impl) /= null
and then not Unit.File_Names (Impl).Locally_Removed
then
-- There is a body, check if it is for this project
if All_Projects
or else
Ultimate_Extending_Project_Of
(Unit.File_Names (Impl).Project) = Project
then
Subunit := False;
if Unit.File_Names (Spec) = null
or else Unit.File_Names (Spec).Locally_Removed
then
-- We have a body with no spec: we need to check if
-- this is a subunit, because gnatls will complain
-- about subunits.
Subunit := Is_Subunit (Unit.File_Names (Impl));
end if;
if not Subunit then
declare
Object_Name : String :=
Get_Name_String
(Unit.File_Names (Impl).Object);
Dep_Name : String :=
Get_Name_String
(Unit.File_Names (Impl).Dep_Name);
begin
Canonical_Case_File_Name (Object_Name);
Canonical_Case_File_Name (Dep_Name);
if Dep_Name in File_Name | File_Name & ".ali"
or else File_Name in Object_Name
| Get_Name_String
(Unit.File_Names (Impl).File)
| Get_Name_String
(Unit.File_Names (Impl)
.Display_File)
then
FN_Source.Source := Unit.File_Names (Impl);
FN_Source.Tree := Tree;
exit Unit_Loop;
end if;
end;
end if;
end if;
elsif Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed
and then
-- We have a spec with no body. Check if it is for this
-- project.
(All_Projects
or else Unit.File_Names (Spec).Project = Project)
then
declare
Object_Name : String :=
Get_Name_String (Unit.File_Names (Spec).Object);
Dep_Name : String :=
Get_Name_String (Unit.File_Names (Spec).Dep_Name);
begin
Canonical_Case_File_Name (Object_Name);
Canonical_Case_File_Name (Dep_Name);
if Dep_Name in File_Name | File_Name & ".ali"
or else File_Name in Object_Name
| Get_Name_String
(Unit.File_Names (Spec).File)
| Get_Name_String
(Unit.File_Names (Spec).Display_File)
then
FN_Source.Source := Unit.File_Names (Spec);
FN_Source.Tree := Tree;
end if;
end;
end if;
Unit := Units_Htable.Get_Next (Tree.Units_HT);
end loop Unit_Loop;
end;
end loop;
end if;
-- Create mapping of ALI files to Source_Id
-- Get all the compilable sources of the projects
declare
Unit : GPR.Unit_Index;
Subunit : Boolean := False;
begin
Unit := Units_Htable.Get_First (Tree.Units_HT);
while Unit /= No_Unit_Index loop
-- We only need to put the library units, body or spec, but not
-- the subunits.
if Unit.File_Names (Impl) /= null
and then not Unit.File_Names (Impl).Locally_Removed
then
Subunit := False;
if Unit.File_Names (Spec) = null
or else Unit.File_Names (Spec).Locally_Removed
then
-- We have a body with no spec: we need to check if this is
-- a subunit.
Subunit := Is_Subunit (Unit.File_Names (Impl));
end if;
if not Subunit then
Add_ALI
(Unit.File_Names (Impl).File,
Spec => False,
Source => Unit.File_Names (Impl));
end if;
end if;
if Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed
then
Add_ALI
(Unit.File_Names (Spec).File,
Spec => True,
Source => Unit.File_Names (Spec));
end if;
Unit := Units_Htable.Get_Next (Tree.Units_HT);
end loop;
end;
end Do_List;
procedure For_All_And_Aggregated is new For_Project_And_Aggregated
(Do_List);
begin
Initialize;
-- Add the external variable GPR_TOOL (default value "gprbuild")
Add_Gpr_Tool_External;
Check_Version_And_Help ("GPRLS", "2015");
Project_File_Name_Expected := False;
-- Loop to scan out arguments
Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop
declare
Next_Argv : constant String := Argument (Next_Arg);
begin
Scan_Arg (Next_Argv);
end;
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
No_Files_In_Command_Line := File_Names.Is_Empty;
if Very_Verbose_Mode then
Closure := False;
Dependable := False;
if not File_Names.Is_Empty then
All_Projects := True;
end if;
elsif Closure then
Dependable := False;
end if;
if Project_File_Name_Expected then
Fail ("project file name missing");
elsif Search_Project_Dir_Expected then
Fail ("directory name missing after -aP");
end if;
-- Output usage information when requested
if Print_Usage then
Usage;
end if;
if Project_File_Name = null
and then File_Names.Is_Empty
and then not Verbose_Mode
then
if Argument_Count = 0 then
Usage;
else
Try_Help;
Exit_Status := E_Fatal;
end if;
Exit_Program (Exit_Status);
end if;
Save_Verbose := Verbose_Mode;
Save_Verbosity_Level := Verbosity_Level;
No_Project_File_Specified := Project_File_Name = null;
if Verbose_Mode and then
No_Project_File_Specified and then
File_Names.Is_Empty
then
Verbose_Mode := False;
Verbosity_Level := None;
Quiet_Output := True;
end if;
if Load_Standard_Base then
Knowledge.Parse_Knowledge_Base (Project_Tree);
end if;
if Target_Name = null then
GPR.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path,
Target_Name => Knowledge.Normalized_Hostname,
Runtime_Name => Runtime_Name_For (Snames.Name_Ada));
else
GPR.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path,
Target_Name => Target_Name.all,
Runtime_Name => Runtime_Name_For (Snames.Name_Ada));
end if;
if Project_File_Name = null then
Look_For_Default_Project (Never_Fail => True);
end if;
if Project_File_Name = null then
Try_Help;
Fail_Program (null, "no project file specified");
end if;
Path_Name := new
String (1 .. Project_File_Name'Length + Project_File_Extension'Length);
Path_Last := Project_File_Name'Length;
if File_Names_Case_Sensitive then
Path_Name (1 .. Path_Last) := Project_File_Name.all;
else
Path_Name (1 .. Path_Last) := To_Lower (Project_File_Name.all);
end if;
Path_Name (Path_Last + 1 .. Path_Name'Last) :=
Project_File_Extension;
if Path_Last < Project_File_Extension'Length + 1
or else Path_Name
(Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
/= Project_File_Extension
then
Path_Last := Path_Name'Last;
end if;
Output_Name := new String'(Path_Name (1 .. Path_Last));
if Target_Name = null then
Target_Name := new String'("");
end if;
if Config_Project_File_Name = null then
Config_Project_File_Name := new String'("");
end if;
Opt.Warning_Mode := Suppress;
begin
Main_Project := No_Project;
Parse_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_Project_File_Name.all,
Autoconf_Specified => False,
Project_File_Name => Output_Name.all,
Project_Tree => Project_Tree,
Project_Node_Tree => Project_Node_Tree,
Packages_To_Check => Packages_To_Check,
Env => Root_Environment,
Allow_Automatic_Generation => True,
Automatically_Generated => Delete_Autoconf_File,
Config_File_Path => Configuration_Project_Path,
Target_Name => Target_Name.all,
Normalized_Hostname => Knowledge.Normalized_Hostname,
Implicit_Project => No_Project_File_Found);
exception
when E : GPR.Conf.Invalid_Config =>
Fail_Program (Project_Tree, Exception_Message (E));
end;
if Main_Project = No_Project then
Fail_Program
(Project_Tree,
"unable to process project file " & Output_Name.all);
end if;
Verbose_Mode := Save_Verbose;
Verbosity_Level := Save_Verbosity_Level;
Quiet_Output := False;
if Verbose_Mode then
Display_Paths;
if No_Project_File_Specified and then File_Names.Is_Empty then
Finish_Program (Project_Tree);
end if;
end if;
Set_Gprls_Mode;
For_All_And_Aggregated (Main_Project, Project_Tree);
if No_Files_In_Command_Line then
Sort_File_Names (File_Names.First_Index, File_Names.Last_Index);
-- Remove duplicates
declare
Idx : Natural := File_Names.First_Index + 1;
function Same_Path (Left, Right : GPR.Source_Id) return Boolean is
(No_Source not in Left | Right
and then (Left = Right or else Left.Path = Right.Path));
begin
while Idx <= File_Names.Last_Index loop
if Same_Path (File_Names (Idx - 1).Source, File_Names (Idx).Source)
and then File_Names (Idx - 1).Source.Project.Name
= File_Names (Idx).Source.Project.Name
then
File_Names.Delete (Idx);
else
Idx := Idx + 1;
end if;
end loop;
end;
end if;
Look_For_Sources;
if Closure then
Display_Closures;
else
Display_Output;
end if;
Finish_Program (Project_Tree);
end Gprls.Main;