-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2009, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 GNAT.Case_Util; use GNAT.Case_Util;
-with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Prj.Com;
with Snames; use Snames;
+with Targparm; use Targparm;
package body Prj.Util is
Free (File);
end Close;
+ ---------------
+ -- Duplicate --
+ ---------------
+
+ procedure Duplicate
+ (This : in out Name_List_Index;
+ In_Tree : Project_Tree_Ref)
+ 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 (In_Tree.Name_Lists);
+ New_Current := Name_List_Table.Last (In_Tree.Name_Lists);
+ This := New_Current;
+ In_Tree.Name_Lists.Table (New_Current) :=
+ (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
+
+ loop
+ Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;
+ exit when Old_Current = No_Name_List;
+ In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;
+ Name_List_Table.Increment_Last (In_Tree.Name_Lists);
+ New_Current := New_Current + 1;
+ In_Tree.Name_Lists.Table (New_Current) :=
+ (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
+ end loop;
+ end if;
+ end Duplicate;
+
-----------------
-- End_Of_File --
-----------------
-------------------
function Executable_Of
- (Project : Project_Id; Main : Name_Id) return Name_Id
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Main : File_Name_Type;
+ Index : Int;
+ Ada_Main : Boolean := True;
+ Language : String := "") return File_Name_Type
is
pragma Assert (Project /= No_Project);
- The_Packages : constant Package_Id :=
- Projects.Table (Project).Decl.Packages;
+ 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);
+ In_Packages => The_Packages,
+ In_Tree => In_Tree);
Executable : Variable_Value :=
Prj.Util.Value_Of
- (Name => Main,
+ (Name => Name_Id (Main),
+ Index => Index,
Attribute_Or_Array_Name => Name_Executable,
- In_Package => Builder_Package);
+ In_Package => Builder_Package,
+ In_Tree => In_Tree);
+
+ Executable_Suffix_Name : Name_Id := No_Name;
+
+ Lang : Language_Ptr;
+
+ Spec_Suffix : Name_Id := No_Name;
+ Body_Suffix : Name_Id := No_Name;
- Executable_Suffix : Variable_Value :=
- Prj.Util.Value_Of
- (Name => Main,
- Attribute_Or_Array_Name =>
- Name_Executable_Suffix,
- In_Package => Builder_Package);
+ Spec_Suffix_Length : Natural := 0;
+ Body_Suffix_Length : Natural := 0;
- Body_Append : constant String := Get_Name_String
- (Projects.Table
- (Project).
- Naming.Current_Body_Suffix);
+ 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
- Spec_Append : constant String := Get_Name_String
- (Projects.Table
- (Project).
- Naming.Current_Spec_Suffix);
+ ------------------
+ -- 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;
+
+ -- 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 then
+ Executable_Suffix_Name := Project.Config.Executable_Suffix;
+
+ 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 : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Name : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
Last : Positive := Name_Len;
- Naming : constant Naming_Data :=
- Projects.Table (Project).Naming;
-
- Spec_Suffix : constant String :=
- Get_Name_String (Naming.Current_Spec_Suffix);
- Body_Suffix : constant String :=
- Get_Name_String (Naming.Current_Body_Suffix);
-
Truncated : Boolean := False;
begin
- if Last > Body_Suffix'Length
- and then Name (Last - Body_Suffix'Length + 1 .. Last) =
- Body_Suffix
+ 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;
+ Last := Last - Body_Suffix_Length;
end if;
- if not Truncated
- and then Last > Spec_Suffix'Length
- and then Name (Last - Spec_Suffix'Length + 1 .. Last) =
- Spec_Suffix
+ 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;
+ Last := Last - Spec_Suffix_Length;
end if;
if Truncated then
Executable :=
Prj.Util.Value_Of
(Name => Name_Find,
+ Index => 0,
Attribute_Or_Array_Name => Name_Executable,
- In_Package => Builder_Package);
+ In_Package => Builder_Package,
+ In_Tree => In_Tree);
end if;
end;
end if;
-- possibly suffixed by the executable suffix.
if Executable /= Nil_Variable_Value
- and then Executable.Value /= Empty_Name
+ and then Executable.Value /= No_Name
+ and then Length_Of_Name (Executable.Value) /= 0
then
+ -- Get the executable name. If Executable_Suffix is defined,
+ -- make sure that it will be the extension of the executable.
+
declare
- Exec_Suffix : String_Access := Get_Executable_Suffix;
- Result : Name_Id := Executable.Value;
+ Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
+ Result : File_Name_Type;
begin
- if Exec_Suffix'Length /= 0 then
- Get_Name_String (Executable.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- -- If the Executable does not end with the executable
- -- suffix, add it.
-
- if Name_Len <= Exec_Suffix'Length
- or else
- Name_Buffer
- (Name_Len - Exec_Suffix'Length + 1 .. Name_Len) /=
- Exec_Suffix.all
- then
- -- Get the original Executable to keep the correct
- -- case for systems where file names are case
- -- insensitive (Windows).
-
- Get_Name_String (Executable.Value);
- Name_Buffer
- (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
- Exec_Suffix.all;
- Name_Len := Name_Len + Exec_Suffix'Length;
- Result := Name_Find;
- end if;
-
- Free (Exec_Suffix);
+ if Executable_Suffix_Name /= No_Name then
+ Executable_Extension_On_Target := Executable_Suffix_Name;
end if;
+ Result := Executable_Name (File_Name_Type (Executable.Value));
+ Executable_Extension_On_Target := Saved_EEOT;
return Result;
end;
end if;
-- otherwise remove any suffix ('.' followed by other characters), if
-- there is one.
- if Name_Len > Body_Append'Length
- and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
- Body_Append
+ 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_Append'Length;
+ Name_Len := Name_Len - Body_Suffix_Length;
- elsif Name_Len > Spec_Append'Length
- and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
- Spec_Append
+ 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_Append'Length;
+ Name_Len := Name_Len - Spec_Suffix_Length;
else
-- Remove any suffix, if there is one
Get_Name_String (Strip_Suffix (Main));
end if;
- if Executable_Suffix /= Nil_Variable_Value
- and then not Executable_Suffix.Default
- then
- -- If attribute Executable_Suffix is specified, add this suffix
+ -- Get the executable name. If Executable_Suffix is defined in the
+ -- configuration, make sure that it will be the extension of the
+ -- executable.
- declare
- Suffix : constant String :=
- Get_Name_String (Executable_Suffix.Value);
- begin
- Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
- Name_Len := Name_Len + Suffix'Length;
- return Name_Find;
- end;
+ declare
+ Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
+ Result : File_Name_Type;
- else
- -- Otherwise, add the standard suffix for the platform, if any
+ begin
+ if Project.Config.Executable_Suffix /= No_Name then
+ Executable_Extension_On_Target :=
+ Project.Config.Executable_Suffix;
+ end if;
- return Executable_Name (Name_Find);
- end if;
+ Result := Executable_Name (Name_Find);
+ Executable_Extension_On_Target := Saved_EEOT;
+ return Result;
+ end;
end Executable_Of;
--------------
-- Open --
----------
- procedure Open (File : out Text_File; Name : in String) is
+ procedure Open (File : out Text_File; Name : String) is
FD : File_Descriptor;
File_Name : String (1 .. Name'Length + 1);
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);
+ Fmode => GNAT.OS_Lib.Text);
+
if FD = Invalid_FD then
File := null;
+
else
File := new Text_File_Data;
File.FD := FD;
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
+ Current_Name : Name_List_Index;
+ List : String_List_Id;
+ Element : String_Element;
+ Last : Name_List_Index :=
+ Name_List_Table.Last (In_Tree.Name_Lists);
+ Value : Name_Id;
+
+ begin
+ Current_Name := Into_List;
+ while Current_Name /= No_Name_List
+ and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List
+ loop
+ Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;
+ end loop;
+
+ List := From_List;
+ while List /= Nil_String loop
+ Element := In_Tree.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
+ (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List));
+
+ Last := Last + 1;
+
+ if Current_Name = No_Name_List then
+ Into_List := Last;
+
+ else
+ In_Tree.Name_Lists.Table (Current_Name).Next := Last;
+ end if;
+
+ Current_Name := Last;
+
+ List := Element.Next;
+ end loop;
+ end Put;
+
--------------
-- Value_Of --
--------------
function Value_Of
(Variable : Variable_Value;
- Default : String)
- return String
+ Default : String) return String
is
begin
if Variable.Kind /= Single
function Value_Of
(Index : Name_Id;
- In_Array : Array_Element_Id)
- return Name_Id
+ In_Array : Array_Element_Id;
+ In_Tree : Project_Tree_Ref) return Name_Id
is
- Current : Array_Element_Id := In_Array;
+ 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 := Array_Elements.Table (Current);
+ Element := In_Tree.Array_Elements.Table (Current);
if not Element.Index_Case_Sensitive then
Get_Name_String (Index);
end if;
while Current /= No_Array_Element loop
- Element := Array_Elements.Table (Current);
+ Element := In_Tree.Array_Elements.Table (Current);
if Real_Index = Element.Index then
exit when Element.Value.Kind /= Single;
end Value_Of;
function Value_Of
- (Index : Name_Id;
- In_Array : Array_Element_Id)
- return Variable_Value
+ (Index : Name_Id;
+ Src_Index : Int := 0;
+ In_Array : Array_Element_Id;
+ In_Tree : Project_Tree_Ref;
+ Force_Lower_Case_Index : Boolean := False) return Variable_Value
is
- Current : Array_Element_Id := In_Array;
- Element : Array_Element;
- Real_Index : Name_Id := Index;
+ 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 := Array_Elements.Table (Current);
+ Element := In_Tree.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;
+ 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 := Array_Elements.Table (Current);
+ Element := In_Tree.Array_Elements.Table (Current);
+ Real_Index_2 := Element.Index;
- if Real_Index = Element.Index then
+ 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 Real_Index_1 = Real_Index_2 and then
+ Src_Index = Element.Src_Index
+ then
return Element.Value;
else
Current := Element.Next;
function Value_Of
(Name : Name_Id;
+ Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
- In_Package : Package_Id)
- return Variable_Value
+ In_Package : Package_Id;
+ In_Tree : Project_Tree_Ref;
+ Force_Lower_Case_Index : Boolean := False) return Variable_Value
is
The_Array : Array_Element_Id;
The_Attribute : Variable_Value := Nil_Variable_Value;
The_Array :=
Value_Of
(Name => Attribute_Or_Array_Name,
- In_Arrays => Packages.Table (In_Package).Decl.Arrays);
+ In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
+ In_Tree => In_Tree);
The_Attribute :=
Value_Of
- (Index => Name,
- In_Array => The_Array);
+ (Index => Name,
+ Src_Index => Index,
+ In_Array => The_Array,
+ In_Tree => In_Tree,
+ Force_Lower_Case_Index => Force_Lower_Case_Index);
-- If there is no array element, look for a variable
The_Attribute :=
Value_Of
(Variable_Name => Attribute_Or_Array_Name,
- In_Variables => Packages.Table (In_Package).Decl.Attributes);
+ In_Variables => In_Tree.Packages.Table
+ (In_Package).Decl.Attributes,
+ In_Tree => In_Tree);
end if;
end if;
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
- In_Arrays : Array_Id)
- return Name_Id
+ In_Arrays : Array_Id;
+ In_Tree : Project_Tree_Ref) return Name_Id
is
- Current : Array_Id := In_Arrays;
+ Current : Array_Id;
The_Array : Array_Data;
begin
+ Current := In_Arrays;
while Current /= No_Array loop
- The_Array := Arrays.Table (Current);
+ The_Array := In_Tree.Arrays.Table (Current);
if The_Array.Name = In_Array then
- return Value_Of (Index, In_Array => The_Array.Value);
+ return Value_Of
+ (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
else
Current := The_Array.Next;
end if;
function Value_Of
(Name : Name_Id;
- In_Arrays : Array_Id)
- return Array_Element_Id
+ In_Arrays : Array_Id;
+ In_Tree : Project_Tree_Ref) return Array_Element_Id
is
- Current : Array_Id := In_Arrays;
- The_Array : Array_Data;
+ Current : Array_Id;
+ The_Array : Array_Data;
begin
+ Current := In_Arrays;
while Current /= No_Array loop
- The_Array := Arrays.Table (Current);
+ The_Array := In_Tree.Arrays.Table (Current);
if The_Array.Name = Name then
return The_Array.Value;
function Value_Of
(Name : Name_Id;
- In_Packages : Package_Id)
- return Package_Id
+ In_Packages : Package_Id;
+ In_Tree : Project_Tree_Ref) return Package_Id
is
- Current : Package_Id := In_Packages;
+ Current : Package_Id;
The_Package : Package_Element;
begin
+ Current := In_Packages;
while Current /= No_Package loop
- The_Package := Packages.Table (Current);
+ The_Package := In_Tree.Packages.Table (Current);
exit when The_Package.Name /= No_Name
and then The_Package.Name = Name;
Current := The_Package.Next;
function Value_Of
(Variable_Name : Name_Id;
- In_Variables : Variable_Id)
- return Variable_Value
+ In_Variables : Variable_Id;
+ In_Tree : Project_Tree_Ref) return Variable_Value
is
- Current : Variable_Id := In_Variables;
+ Current : Variable_Id;
The_Variable : Variable;
begin
+ Current := In_Variables;
while Current /= No_Variable loop
- The_Variable := Variable_Elements.Table (Current);
+ The_Variable :=
+ In_Tree.Variable_Elements.Table (Current);
if Variable_Name = The_Variable.Name then
return The_Variable.Value;
OSDN Git Service
