------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, 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 Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Directories;
with Ada.Unchecked_Deallocation;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Regexp; use GNAT.Regexp;
with ALI; use ALI;
with Osint; use Osint;
with Output; use Output;
with Opt;
with Prj.Com;
with Snames; use Snames;
with Table;
with Targparm; use Targparm;
with GNAT.HTable;
package body Prj.Util is
package Source_Info_Table is new Table.Table
(Table_Component_Type => Source_Info_Iterator,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makeutl.Source_Info_Table");
package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Natural,
No_Element => 0,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
procedure Free is new Ada.Unchecked_Deallocation
(Text_File_Data, Text_File);
-----------
-- Close --
-----------
procedure Close (File : in out Text_File) is
Len : Integer;
Status : Boolean;
begin
if File = null then
Prj.Com.Fail ("Close attempted on an invalid Text_File");
end if;
if File.Out_File then
if File.Buffer_Len > 0 then
Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
if Len /= File.Buffer_Len then
Prj.Com.Fail ("Unable to write to an out Text_File");
end if;
end if;
Close (File.FD, Status);
if not Status then
Prj.Com.Fail ("Unable to close an out Text_File");
end if;
else
-- Close in file, no need to test status, since this is a file that
-- we read, and the file was read successfully before we closed it.
Close (File.FD);
end if;
Free (File);
end Close;
------------
-- Create --
------------
procedure Create (File : out Text_File; Name : String) is
FD : File_Descriptor;
File_Name : String (1 .. Name'Length + 1);
begin
File_Name (1 .. Name'Length) := Name;
File_Name (File_Name'Last) := ASCII.NUL;
FD := Create_File (Name => File_Name'Address,
Fmode => GNAT.OS_Lib.Text);
if FD = Invalid_FD then
File := null;
else
File := new Text_File_Data;
File.FD := FD;
File.Out_File := True;
File.End_Of_File_Reached := True;
end if;
end Create;
---------------
-- Duplicate --
---------------
procedure Duplicate
(This : in out Name_List_Index;
Shared : Shared_Project_Tree_Data_Access)
is
Old_Current : Name_List_Index;
New_Current : Name_List_Index;
begin
if This /= No_Name_List then
Old_Current := This;
Name_List_Table.Increment_Last (Shared.Name_Lists);
New_Current := Name_List_Table.Last (Shared.Name_Lists);
This := New_Current;
Shared.Name_Lists.Table (New_Current) :=
(Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
loop
Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
exit when Old_Current = No_Name_List;
Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
Name_List_Table.Increment_Last (Shared.Name_Lists);
New_Current := New_Current + 1;
Shared.Name_Lists.Table (New_Current) :=
(Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
end loop;
end if;
end Duplicate;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : Text_File) return Boolean is
begin
if File = null then
Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
end if;
return File.End_Of_File_Reached;
end End_Of_File;
-------------------
-- Executable_Of --
-------------------
function Executable_Of
(Project : Project_Id;
Shared : Shared_Project_Tree_Data_Access;
Main : File_Name_Type;
Index : Int;
Ada_Main : Boolean := True;
Language : String := "";
Include_Suffix : Boolean := True) return File_Name_Type
is
pragma Assert (Project /= No_Project);
The_Packages : constant Package_Id := Project.Decl.Packages;
Builder_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Builder,
In_Packages => The_Packages,
Shared => Shared);
Executable : Variable_Value :=
Prj.Util.Value_Of
(Name => Name_Id (Main),
Index => Index,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Shared);
Lang : Language_Ptr;
Spec_Suffix : Name_Id := No_Name;
Body_Suffix : Name_Id := No_Name;
Spec_Suffix_Length : Natural := 0;
Body_Suffix_Length : Natural := 0;
procedure Get_Suffixes
(B_Suffix : File_Name_Type;
S_Suffix : File_Name_Type);
-- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
function Add_Suffix (File : File_Name_Type) return File_Name_Type;
-- Return the name of the executable, based on File, and adding the
-- executable suffix if needed
------------------
-- Get_Suffixes --
------------------
procedure Get_Suffixes
(B_Suffix : File_Name_Type;
S_Suffix : File_Name_Type)
is
begin
if B_Suffix /= No_File then
Body_Suffix := Name_Id (B_Suffix);
Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
end if;
if S_Suffix /= No_File then
Spec_Suffix := Name_Id (S_Suffix);
Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
end if;
end Get_Suffixes;
----------------
-- Add_Suffix --
----------------
function Add_Suffix (File : File_Name_Type) return File_Name_Type is
Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
Result : File_Name_Type;
Suffix_From_Project : Variable_Value;
begin
if Include_Suffix then
if Project.Config.Executable_Suffix /= No_Name then
Executable_Extension_On_Target :=
Project.Config.Executable_Suffix;
end if;
Result := Executable_Name (File);
Executable_Extension_On_Target := Saved_EEOT;
return Result;
elsif Builder_Package /= No_Package then
-- If the suffix is specified in the project itself, as opposed to
-- the config file, it needs to be taken into account. However,
-- when the project was processed, in both cases the suffix was
-- stored in Project.Config, so get it from the project again.
Suffix_From_Project :=
Prj.Util.Value_Of
(Variable_Name => Name_Executable_Suffix,
In_Variables =>
Shared.Packages.Table (Builder_Package).Decl.Attributes,
Shared => Shared);
if Suffix_From_Project /= Nil_Variable_Value
and then Suffix_From_Project.Value /= No_Name
then
Executable_Extension_On_Target := Suffix_From_Project.Value;
Result := Executable_Name (File);
Executable_Extension_On_Target := Saved_EEOT;
return Result;
end if;
end if;
return File;
end Add_Suffix;
-- Start of processing for Executable_Of
begin
if Ada_Main then
Lang := Get_Language_From_Name (Project, "ada");
elsif Language /= "" then
Lang := Get_Language_From_Name (Project, Language);
end if;
if Lang /= null then
Get_Suffixes
(B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
end if;
if Builder_Package /= No_Package then
if Executable = Nil_Variable_Value and then Ada_Main then
Get_Name_String (Main);
-- Try as index the name minus the implementation suffix or minus
-- the specification suffix.
declare
Name : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
Last : Positive := Name_Len;
Truncated : Boolean := False;
begin
if Body_Suffix /= No_Name
and then Last > Natural (Length_Of_Name (Body_Suffix))
and then Name (Last - Body_Suffix_Length + 1 .. Last) =
Get_Name_String (Body_Suffix)
then
Truncated := True;
Last := Last - Body_Suffix_Length;
end if;
if Spec_Suffix /= No_Name
and then not Truncated
and then Last > Spec_Suffix_Length
and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
Get_Name_String (Spec_Suffix)
then
Truncated := True;
Last := Last - Spec_Suffix_Length;
end if;
if Truncated then
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
Executable :=
Prj.Util.Value_Of
(Name => Name_Find,
Index => 0,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Shared);
end if;
end;
end if;
-- If we have found an Executable attribute, return its value,
-- possibly suffixed by the executable suffix.
if Executable /= Nil_Variable_Value
and then Executable.Value /= No_Name
and then Length_Of_Name (Executable.Value) /= 0
then
return Add_Suffix (File_Name_Type (Executable.Value));
end if;
end if;
Get_Name_String (Main);
-- If there is a body suffix or a spec suffix, remove this suffix,
-- otherwise remove any suffix ('.' followed by other characters), if
-- there is one.
if Body_Suffix /= No_Name
and then Name_Len > Body_Suffix_Length
and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
Get_Name_String (Body_Suffix)
then
-- Found the body termination, remove it
Name_Len := Name_Len - Body_Suffix_Length;
elsif Spec_Suffix /= No_Name
and then Name_Len > Spec_Suffix_Length
and then
Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
Get_Name_String (Spec_Suffix)
then
-- Found the spec termination, remove it
Name_Len := Name_Len - Spec_Suffix_Length;
else
-- Remove any suffix, if there is one
Get_Name_String (Strip_Suffix (Main));
end if;
return Add_Suffix (Name_Find);
end Executable_Of;
---------------------------
-- For_Interface_Sources --
---------------------------
procedure For_Interface_Sources
(Tree : Project_Tree_Ref;
Project : Project_Id)
is
use Ada;
use type Ada.Containers.Count_Type;
package Dep_Names is new Containers.Indefinite_Ordered_Sets (String);
function Load_ALI (Filename : String) return ALI_Id;
-- Load an ALI file and return its id
--------------
-- Load_ALI --
--------------
function Load_ALI (Filename : String) return ALI_Id is
Result : ALI_Id := No_ALI_Id;
Text : Text_Buffer_Ptr;
Lib_File : File_Name_Type;
begin
if Directories.Exists (Filename) then
Name_Len := 0;
Add_Str_To_Name_Buffer (Filename);
Lib_File := Name_Find;
Text := Osint.Read_Library_Info (Lib_File);
Result :=
ALI.Scan_ALI
(Lib_File,
Text,
Ignore_ED => False,
Err => True,
Read_Lines => "UD");
Free (Text);
end if;
return Result;
end Load_ALI;
-- Local declarations
Iter : Source_Iterator;
Sid : Source_Id;
ALI : ALI_Id;
First_Unit : Unit_Id;
Second_Unit : Unit_Id;
Body_Needed : Boolean;
Deps : Dep_Names.Set;
-- Start of processing for For_Interface_Sources
begin
if Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Tree);
else
Iter := For_Each_Source (Tree, Project);
end if;
-- First look at each spec, check if the body is needed
loop
Sid := Element (Iter);
exit when Sid = No_Source;
-- Skip sources that are removed/excluded and sources not part of
-- the interface for standalone libraries.
if Sid.Kind = Spec
and then not Sid.Locally_Removed
and then (Project.Standalone_Library = No
or else Sid.Declared_In_Interfaces)
then
Action (Sid);
-- Check ALI for dependencies on body and sep
ALI :=
Load_ALI
(Get_Name_String (Get_Object_Directory (Sid.Project, True))
& Get_Name_String (Sid.Dep_Name));
if ALI /= No_ALI_Id then
First_Unit := ALIs.Table (ALI).First_Unit;
Second_Unit := No_Unit_Id;
Body_Needed := True;
-- If there is both a spec and a body, check if both needed
if Units.Table (First_Unit).Utype = Is_Body then
Second_Unit := ALIs.Table (ALI).Last_Unit;
-- If the body is not needed, then reset First_Unit
if not Units.Table (Second_Unit).Body_Needed_For_SAL then
Body_Needed := False;
end if;
elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
Body_Needed := False;
end if;
-- Handle all the separates, if any
if Body_Needed then
if Other_Part (Sid) /= null then
Deps.Include (Get_Name_String (Other_Part (Sid).File));
end if;
for Dep in ALIs.Table (ALI).First_Sdep ..
ALIs.Table (ALI).Last_Sdep
loop
if Sdep.Table (Dep).Subunit_Name /= No_Name then
Deps.Include
(Get_Name_String (Sdep.Table (Dep).Sfile));
end if;
end loop;
end if;
end if;
end if;
Next (Iter);
end loop;
-- Now handle the bodies and separates if needed
if Deps.Length /= 0 then
Iter := For_Each_Source (Tree, Project);
loop
Sid := Element (Iter);
exit when Sid = No_Source;
if Sid.Kind /= Spec
and then Deps.Contains (Get_Name_String (Sid.File))
then
Action (Sid);
end if;
Next (Iter);
end loop;
end if;
end For_Interface_Sources;
--------------
-- Get_Line --
--------------
procedure Get_Line
(File : Text_File;
Line : out String;
Last : out Natural)
is
C : Character;
procedure Advance;
-------------
-- Advance --
-------------
procedure Advance is
begin
if File.Cursor = File.Buffer_Len then
File.Buffer_Len :=
Read
(FD => File.FD,
A => File.Buffer'Address,
N => File.Buffer'Length);
if File.Buffer_Len = 0 then
File.End_Of_File_Reached := True;
return;
else
File.Cursor := 1;
end if;
else
File.Cursor := File.Cursor + 1;
end if;
end Advance;
-- Start of processing for Get_Line
begin
if File = null then
Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
elsif File.Out_File then
Prj.Com.Fail ("Get_Line attempted on an out file");
end if;
Last := Line'First - 1;
if not File.End_Of_File_Reached then
loop
C := File.Buffer (File.Cursor);
exit when C = ASCII.CR or else C = ASCII.LF;
Last := Last + 1;
Line (Last) := C;
Advance;
if File.End_Of_File_Reached then
return;
end if;
exit when Last = Line'Last;
end loop;
if C = ASCII.CR or else C = ASCII.LF then
Advance;
if File.End_Of_File_Reached then
return;
end if;
end if;
if C = ASCII.CR
and then File.Buffer (File.Cursor) = ASCII.LF
then
Advance;
end if;
end if;
end Get_Line;
----------------
-- Initialize --
----------------
procedure Initialize
(Iter : out Source_Info_Iterator;
For_Project : Name_Id)
is
Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
begin
if Ind = 0 then
Iter := (No_Source_Info, 0);
else
Iter := Source_Info_Table.Table (Ind);
end if;
end Initialize;
--------------
-- Is_Valid --
--------------
function Is_Valid (File : Text_File) return Boolean is
begin
return File /= null;
end Is_Valid;
----------
-- Next --
----------
procedure Next (Iter : in out Source_Info_Iterator) is
begin
if Iter.Next = 0 then
Iter.Info := No_Source_Info;
else
Iter := Source_Info_Table.Table (Iter.Next);
end if;
end Next;
----------
-- Open --
----------
procedure Open (File : out Text_File; Name : String) is
FD : File_Descriptor;
File_Name : String (1 .. Name'Length + 1);
begin
File_Name (1 .. Name'Length) := Name;
File_Name (File_Name'Last) := ASCII.NUL;
FD := Open_Read (Name => File_Name'Address,
Fmode => GNAT.OS_Lib.Text);
if FD = Invalid_FD then
File := null;
else
File := new Text_File_Data;
File.FD := FD;
File.Buffer_Len :=
Read (FD => FD,
A => File.Buffer'Address,
N => File.Buffer'Length);
if File.Buffer_Len = 0 then
File.End_Of_File_Reached := True;
else
File.Cursor := 1;
end if;
end if;
end Open;
---------
-- Put --
---------
procedure Put
(Into_List : in out Name_List_Index;
From_List : String_List_Id;
In_Tree : Project_Tree_Ref;
Lower_Case : Boolean := False)
is
Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
Current_Name : Name_List_Index;
List : String_List_Id;
Element : String_Element;
Last : Name_List_Index :=
Name_List_Table.Last (Shared.Name_Lists);
Value : Name_Id;
begin
Current_Name := Into_List;
while Current_Name /= No_Name_List
and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
loop
Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
end loop;
List := From_List;
while List /= Nil_String loop
Element := Shared.String_Elements.Table (List);
Value := Element.Value;
if Lower_Case then
Get_Name_String (Value);
To_Lower (Name_Buffer (1 .. Name_Len));
Value := Name_Find;
end if;
Name_List_Table.Append
(Shared.Name_Lists, (Name => Value, Next => No_Name_List));
Last := Last + 1;
if Current_Name = No_Name_List then
Into_List := Last;
else
Shared.Name_Lists.Table (Current_Name).Next := Last;
end if;
Current_Name := Last;
List := Element.Next;
end loop;
end Put;
procedure Put (File : Text_File; S : String) is
Len : Integer;
begin
if File = null then
Prj.Com.Fail ("Attempted to write on an invalid Text_File");
elsif not File.Out_File then
Prj.Com.Fail ("Attempted to write an in Text_File");
end if;
if File.Buffer_Len + S'Length > File.Buffer'Last then
-- Write buffer
Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
if Len /= File.Buffer_Len then
Prj.Com.Fail ("Failed to write to an out Text_File");
end if;
File.Buffer_Len := 0;
end if;
File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
File.Buffer_Len := File.Buffer_Len + S'Length;
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (File : Text_File; Line : String) is
L : String (1 .. Line'Length + 1);
begin
L (1 .. Line'Length) := Line;
L (L'Last) := ASCII.LF;
Put (File, L);
end Put_Line;
---------------------------
-- Read_Source_Info_File --
---------------------------
procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
File : Text_File;
Info : Source_Info_Iterator;
Proj : Name_Id;
procedure Report_Error;
------------------
-- Report_Error --
------------------
procedure Report_Error is
begin
Write_Line ("errors in source info file """ &
Tree.Source_Info_File_Name.all & '"');
Tree.Source_Info_File_Exists := False;
end Report_Error;
begin
Source_Info_Project_HTable.Reset;
Source_Info_Table.Init;
if Tree.Source_Info_File_Name = null then
Tree.Source_Info_File_Exists := False;
return;
end if;
Open (File, Tree.Source_Info_File_Name.all);
if not Is_Valid (File) then
if Opt.Verbose_Mode then
Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
" does not exist");
end if;
Tree.Source_Info_File_Exists := False;
return;
end if;
Tree.Source_Info_File_Exists := True;
if Opt.Verbose_Mode then
Write_Line ("Reading source info file " &
Tree.Source_Info_File_Name.all);
end if;
Source_Loop :
while not End_Of_File (File) loop
Info := (new Source_Info_Data, 0);
Source_Info_Table.Increment_Last;
-- project name
Get_Line (File, Name_Buffer, Name_Len);
Proj := Name_Find;
Info.Info.Project := Proj;
Info.Next := Source_Info_Project_HTable.Get (Proj);
Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
if End_Of_File (File) then
Report_Error;
exit Source_Loop;
end if;
-- language name
Get_Line (File, Name_Buffer, Name_Len);
Info.Info.Language := Name_Find;
if End_Of_File (File) then
Report_Error;
exit Source_Loop;
end if;
-- kind
Get_Line (File, Name_Buffer, Name_Len);
Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
if End_Of_File (File) then
Report_Error;
exit Source_Loop;
end if;
-- display path name
Get_Line (File, Name_Buffer, Name_Len);
Info.Info.Display_Path_Name := Name_Find;
Info.Info.Path_Name := Info.Info.Display_Path_Name;
if End_Of_File (File) then
Report_Error;
exit Source_Loop;
end if;
-- optional fields
Option_Loop :
loop
Get_Line (File, Name_Buffer, Name_Len);
exit Option_Loop when Name_Len = 0;
if Name_Len <= 2 then
Report_Error;
exit Source_Loop;
else
if Name_Buffer (1 .. 2) = "P=" then
Name_Buffer (1 .. Name_Len - 2) :=
Name_Buffer (3 .. Name_Len);
Name_Len := Name_Len - 2;
Info.Info.Path_Name := Name_Find;
elsif Name_Buffer (1 .. 2) = "U=" then
Name_Buffer (1 .. Name_Len - 2) :=
Name_Buffer (3 .. Name_Len);
Name_Len := Name_Len - 2;
Info.Info.Unit_Name := Name_Find;
elsif Name_Buffer (1 .. 2) = "I=" then
Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
Info.Info.Naming_Exception := Yes;
elsif Name_Buffer (1 .. Name_Len) = "N=I" then
Info.Info.Naming_Exception := Inherited;
else
Report_Error;
exit Source_Loop;
end if;
end if;
end loop Option_Loop;
Source_Info_Table.Table (Source_Info_Table.Last) := Info;
end loop Source_Loop;
Close (File);
exception
when others =>
Close (File);
Report_Error;
end Read_Source_Info_File;
--------------------
-- Source_Info_Of --
--------------------
function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
begin
return Iter.Info;
end Source_Info_Of;
--------------
-- Value_Of --
--------------
function Value_Of
(Variable : Variable_Value;
Default : String) return String
is
begin
if Variable.Kind /= Single
or else Variable.Default
or else Variable.Value = No_Name
then
return Default;
else
return Get_Name_String (Variable.Value);
end if;
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id
is
Current : Array_Element_Id;
Element : Array_Element;
Real_Index : Name_Id := Index;
begin
Current := In_Array;
if Current = No_Array_Element then
return No_Name;
end if;
Element := Shared.Array_Elements.Table (Current);
if not Element.Index_Case_Sensitive then
Get_Name_String (Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index := Name_Find;
end if;
while Current /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Current);
if Real_Index = Element.Index then
exit when Element.Value.Kind /= Single;
exit when Element.Value.Value = Empty_String;
return Element.Value.Value;
else
Current := Element.Next;
end if;
end loop;
return No_Name;
end Value_Of;
function Value_Of
(Index : Name_Id;
Src_Index : Int := 0;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value
is
Current : Array_Element_Id;
Element : Array_Element;
Real_Index_1 : Name_Id;
Real_Index_2 : Name_Id;
begin
Current := In_Array;
if Current = No_Array_Element then
return Nil_Variable_Value;
end if;
Element := Shared.Array_Elements.Table (Current);
Real_Index_1 := Index;
if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
if Index /= All_Other_Names then
Get_Name_String (Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index_1 := Name_Find;
end if;
end if;
while Current /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Current);
Real_Index_2 := Element.Index;
if not Element.Index_Case_Sensitive
or else Force_Lower_Case_Index
then
if Element.Index /= All_Other_Names then
Get_Name_String (Element.Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index_2 := Name_Find;
end if;
end if;
if Src_Index = Element.Src_Index and then
(Real_Index_1 = Real_Index_2 or else
(Real_Index_2 /= All_Other_Names and then
Allow_Wildcards and then
Match (Get_Name_String (Real_Index_1),
Compile (Get_Name_String (Real_Index_2),
Glob => True))))
then
return Element.Value;
else
Current := Element.Next;
end if;
end loop;
return Nil_Variable_Value;
end Value_Of;
function Value_Of
(Name : Name_Id;
Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value
is
The_Array : Array_Element_Id;
The_Attribute : Variable_Value := Nil_Variable_Value;
begin
if In_Package /= No_Package then
-- First, look if there is an array element that fits
The_Array :=
Value_Of
(Name => Attribute_Or_Array_Name,
In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
Shared => Shared);
The_Attribute :=
Value_Of
(Index => Name,
Src_Index => Index,
In_Array => The_Array,
Shared => Shared,
Force_Lower_Case_Index => Force_Lower_Case_Index,
Allow_Wildcards => Allow_Wildcards);
-- If there is no array element, look for a variable
if The_Attribute = Nil_Variable_Value then
The_Attribute :=
Value_Of
(Variable_Name => Attribute_Or_Array_Name,
In_Variables => Shared.Packages.Table
(In_Package).Decl.Attributes,
Shared => Shared);
end if;
end if;
return The_Attribute;
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id
is
Current : Array_Id;
The_Array : Array_Data;
begin
Current := In_Arrays;
while Current /= No_Array loop
The_Array := Shared.Arrays.Table (Current);
if The_Array.Name = In_Array then
return Value_Of
(Index, In_Array => The_Array.Value, Shared => Shared);
else
Current := The_Array.Next;
end if;
end loop;
return No_Name;
end Value_Of;
function Value_Of
(Name : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id
is
Current : Array_Id;
The_Array : Array_Data;
begin
Current := In_Arrays;
while Current /= No_Array loop
The_Array := Shared.Arrays.Table (Current);
if The_Array.Name = Name then
return The_Array.Value;
else
Current := The_Array.Next;
end if;
end loop;
return No_Array_Element;
end Value_Of;
function Value_Of
(Name : Name_Id;
In_Packages : Package_Id;
Shared : Shared_Project_Tree_Data_Access) return Package_Id
is
Current : Package_Id;
The_Package : Package_Element;
begin
Current := In_Packages;
while Current /= No_Package loop
The_Package := Shared.Packages.Table (Current);
exit when The_Package.Name /= No_Name
and then The_Package.Name = Name;
Current := The_Package.Next;
end loop;
return Current;
end Value_Of;
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id;
Shared : Shared_Project_Tree_Data_Access) return Variable_Value
is
Current : Variable_Id;
The_Variable : Variable;
begin
Current := In_Variables;
while Current /= No_Variable loop
The_Variable := Shared.Variable_Elements.Table (Current);
if Variable_Name = The_Variable.Name then
return The_Variable.Value;
else
Current := The_Variable.Next;
end if;
end loop;
return Nil_Variable_Value;
end Value_Of;
----------------------------
-- Write_Source_Info_File --
----------------------------
procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
Iter : Source_Iterator := For_Each_Source (Tree);
Source : Prj.Source_Id;
File : Text_File;
begin
if Opt.Verbose_Mode then
Write_Line ("Writing new source info file " &
Tree.Source_Info_File_Name.all);
end if;
Create (File, Tree.Source_Info_File_Name.all);
if not Is_Valid (File) then
Write_Line ("warning: unable to create source info file """ &
Tree.Source_Info_File_Name.all & '"');
return;
end if;
loop
Source := Element (Iter);
exit when Source = No_Source;
if not Source.Locally_Removed and then
Source.Replaced_By = No_Source
then
-- Project name
Put_Line (File, Get_Name_String (Source.Project.Name));
-- Language name
Put_Line (File, Get_Name_String (Source.Language.Name));
-- Kind
Put_Line (File, Source.Kind'Img);
-- Display path name
Put_Line (File, Get_Name_String (Source.Path.Display_Name));
-- Optional lines:
-- Path name (P=)
if Source.Path.Name /= Source.Path.Display_Name then
Put (File, "P=");
Put_Line (File, Get_Name_String (Source.Path.Name));
end if;
-- Unit name (U=)
if Source.Unit /= No_Unit_Index then
Put (File, "U=");
Put_Line (File, Get_Name_String (Source.Unit.Name));
end if;
-- Multi-source index (I=)
if Source.Index /= 0 then
Put (File, "I=");
Put_Line (File, Source.Index'Img);
end if;
-- Naming exception ("N=T");
if Source.Naming_Exception = Yes then
Put_Line (File, "N=Y");
elsif Source.Naming_Exception = Inherited then
Put_Line (File, "N=I");
end if;
-- Empty line to indicate end of info on this source
Put_Line (File, "");
end if;
Next (Iter);
end loop;
Close (File);
end Write_Source_Info_File;
---------------
-- Write_Str --
---------------
procedure Write_Str
(S : String;
Max_Length : Positive;
Separator : Character)
is
First : Positive := S'First;
Last : Natural := S'Last;
begin
-- Nothing to do for empty strings
if S'Length > 0 then
-- Start on a new line if current line is already longer than
-- Max_Length.
if Positive (Column) >= Max_Length then
Write_Eol;
end if;
-- If length of remainder is longer than Max_Length, we need to
-- cut the remainder in several lines.
while Positive (Column) + S'Last - First > Max_Length loop
-- Try the maximum length possible
Last := First + Max_Length - Positive (Column);
-- Look for last Separator in the line
while Last >= First and then S (Last) /= Separator loop
Last := Last - 1;
end loop;
-- If we do not find a separator, we output the maximum length
-- possible.
if Last < First then
Last := First + Max_Length - Positive (Column);
end if;
Write_Line (S (First .. Last));
-- Set the beginning of the new remainder
First := Last + 1;
end loop;
-- What is left goes to the buffer, without EOL
Write_Str (S (First .. S'Last));
end if;
end Write_Str;
end Prj.Util;