OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2009-11-30  Thomas Quinot  <quinot@adacore.com>

	* osint.adb: Minor reformatting

2009-11-30  Vincent Celier  <celier@adacore.com>

	* makeutl.ads, makeutl.adb (Base_Name_Index_For): New function to get
	the base name of a main without the extension, with an eventual source
	index.
	(Mains.Get_Index): New procedure to set the source index of a main
	(Mains.Get_Index): New function to get the source index of a main
	* prj-attr.adb: New attributes Config_Body_File_Name_Index,
	Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and
	Multi_Unit_Switches.
	* prj-nmsc.adb (Process_Compiler): Takle into account new attributes
	Config_Body_File_Name_Index, Config_Spec_File_Name_Index,
	Multi_Unit_Object_Separator and Multi_Unit_Switches.
	Allow only one character for Multi_Unit_Object_Separator.
	* prj-proc.adb (Process_Declarative_Items): Take into account the
	source indexes in indexes of associative array attribute declarations.
	* prj.adb (Object_Name): New function to get the object file name for
	units in multi-unit sources.
	* prj.ads (Language_Config): New components Multi_Unit_Switches,
	Multi_Unit_Object_Separator Config_Body_Index and Config_Spec_Index.
	(Object_Name): New function to get the object file name for units in
	multi-unit sources.
	* snames.ads-tmpl: New standard names Config_Body_File_Name_Index,
	Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and
	Multi_Unit_Switches.

From-SVN: r154782
This commit is contained in:
Arnaud Charlet 2009-11-30 11:59:41 +01:00
parent a8fc928da3
commit c9df623a12
10 changed files with 239 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/ChangeLog
View File

@ -1,3 +1,33 @@
2009-11-30 Thomas Quinot <quinot@adacore.com>
* osint.adb: Minor reformatting
2009-11-30 Vincent Celier <celier@adacore.com>
* makeutl.ads, makeutl.adb (Base_Name_Index_For): New function to get
the base name of a main without the extension, with an eventual source
index.
(Mains.Get_Index): New procedure to set the source index of a main
(Mains.Get_Index): New function to get the source index of a main
* prj-attr.adb: New attributes Config_Body_File_Name_Index,
Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and
Multi_Unit_Switches.
* prj-nmsc.adb (Process_Compiler): Takle into account new attributes
Config_Body_File_Name_Index, Config_Spec_File_Name_Index,
Multi_Unit_Object_Separator and Multi_Unit_Switches.
Allow only one character for Multi_Unit_Object_Separator.
* prj-proc.adb (Process_Declarative_Items): Take into account the
source indexes in indexes of associative array attribute declarations.
* prj.adb (Object_Name): New function to get the object file name for
units in multi-unit sources.
* prj.ads (Language_Config): New components Multi_Unit_Switches,
Multi_Unit_Object_Separator Config_Body_Index and Config_Spec_Index.
(Object_Name): New function to get the object file name for units in
multi-unit sources.
* snames.ads-tmpl: New standard names Config_Body_File_Name_Index,
Config_Spec_File_Name_Index, Multi_Unit_Object_Separator and
Multi_Unit_Switches.
2009-11-30 Arnaud Charlet <charlet@adacore.com>
* s-tassta.adb: Update comment.

66
gcc/ada/makeutl.adb
View File

@ -157,6 +157,45 @@ package body Makeutl is
end if;
end Add_Linker_Option;
-------------------------
-- Base_Name_Index_For --
-------------------------
function Base_Name_Index_For
(Main : String;
Main_Index : Int;
Index_Separator : Character) return File_Name_Type
is
Result : File_Name_Type;
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Base_Name (Main));
-- Remove the extension, if any, that is the last part of the base
-- name starting with a dot and following some characters.
for J in reverse 2 .. Name_Len loop
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
exit;
end if;
end loop;
-- Add the index info, if index is different from 0
if Main_Index > 0 then
Add_Char_To_Name_Buffer (Index_Separator);
declare
Img : constant String := Main_Index'Img;
begin
Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
end;
end if;
Result := Name_Find;
return Result;
end Base_Name_Index_For;
------------------------------
-- Check_Source_Info_In_ALI --
------------------------------
@ -599,6 +638,7 @@ package body Makeutl is
type File_And_Loc is record
File_Name : File_Name_Type;
Index : Int := 0;
Location : Source_Ptr := No_Location;
end record;
@ -623,7 +663,7 @@ package body Makeutl is
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
Names.Increment_Last;
Names.Table (Names.Last) := (Name_Find, No_Location);
Names.Table (Names.Last) := (Name_Find, 0, No_Location);
end Add_Main;
------------
@ -636,6 +676,19 @@ package body Makeutl is
Mains.Reset;
end Delete;
---------------
-- Get_Index --
---------------
function Get_Index return Int is
begin
if Current in Names.First .. Names.Last then
return Names.Table (Current).Index;
else
return 0;
end if;
end Get_Index;
------------------
-- Get_Location --
------------------
@ -681,6 +734,17 @@ package body Makeutl is
Current := 0;
end Reset;
---------------
-- Set_Index --
---------------
procedure Set_Index (Index : Int) is
begin
if Names.Last > 0 then
Names.Table (Names.Last).Index := Index;
end if;
end Set_Index;
------------------
-- Set_Location --
------------------

13
gcc/ada/makeutl.ads
View File

@ -60,7 +60,14 @@ package Makeutl is
function Create_Name (Name : String) return File_Name_Type;
function Create_Name (Name : String) return Name_Id;
function Create_Name (Name : String) return Path_Name_Type;
-- Get the Name_Id of a name
-- Get an id for a name
function Base_Name_Index_For
(Main : String;
Main_Index : Int;
Index_Separator : Character) return File_Name_Type;
-- Returns the base name of Main, without the extension, plus the
-- Index_Separator followed by the Main_Index, if Main_Index is not 0.
function Executable_Prefix_Path return String;
-- Return the absolute path parent directory of the directory where the
@ -143,6 +150,8 @@ package Makeutl is
procedure Add_Main (Name : String);
-- Add one main to the table
procedure Set_Index (Index : Int);
procedure Set_Location (Location : Source_Ptr);
-- Set the location of the last main added. By default, the location is
-- No_Location.
@ -157,6 +166,8 @@ package Makeutl is
-- Increase the index and return the next main. If table is exhausted,
-- return an empty string.
function Get_Index return Int;
function Get_Location return Source_Ptr;
-- Get the location of the current main

2
gcc/ada/osint.adb
View File

@ -138,7 +138,7 @@ package body Osint is
Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. Are we doing this to avoid withing
-- Interfaces.C.Strings ???
-- Caller must free result
-- Caller must free result.
function Include_Dir_Default_Prefix return String_Access;
-- Same as exported version, except returns a String_Access

6
gcc/ada/prj-attr.adb
View File

@ -179,6 +179,8 @@ package body Prj.Attr is
"Sapath_syntax#" &
"Saobject_file_suffix#" &
"Laobject_file_switches#" &
"Lamulti_unit_switches#" &
"Samulti_unit_object_separator#" &
-- Configuration - Mapping files
@ -190,8 +192,10 @@ package body Prj.Attr is
"Laconfig_file_switches#" &
"Saconfig_body_file_name#" &
"Saconfig_spec_file_name#" &
"Saconfig_body_file_name_index#" &
"Saconfig_body_file_name_pattern#" &
"Saconfig_spec_file_name#" &
"Saconfig_spec_file_name_index#" &
"Saconfig_spec_file_name_pattern#" &
"Saconfig_file_unique#" &

48
gcc/ada/prj-nmsc.adb
View File

@ -1431,6 +1431,34 @@ package body Prj.Nmsc is
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Multi_Unit_Switches =>
Put (Into_List =>
Lang_Index.Config.Multi_Unit_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Multi_Unit_Object_Separator =>
Get_Name_String (Element.Value.Value);
if Name_Len /= 1 then
Error_Msg
(Data.Flags,
"multi-unit object separator must have " &
"a single character",
Element.Value.Location, Project);
elsif Name_Buffer (1) = ' ' then
Error_Msg
(Data.Flags,
"multi-unit object separator cannot be " &
"a space",
Element.Value.Location, Project);
else
Lang_Index.Config.Multi_Unit_Object_Separator :=
Name_Buffer (1);
end if;
when Name_Path_Syntax =>
begin
Lang_Index.Config.Path_Syntax :=
@ -1552,10 +1580,18 @@ package body Prj.Nmsc is
Lang_Index.Config.Config_Body :=
Element.Value.Value;
when Name_Config_Body_File_Name_Index =>
-- Attribute Config_Body_File_Name_Index
-- ( < Language > )
Lang_Index.Config.Config_Body_Index :=
Element.Value.Value;
when Name_Config_Body_File_Name_Pattern =>
-- Attribute Config_Body_File_Name_Pattern
-- (<language>)
-- (<language>)
Lang_Index.Config.Config_Body_Pattern :=
Element.Value.Value;
@ -1567,10 +1603,18 @@ package body Prj.Nmsc is
Lang_Index.Config.Config_Spec :=
Element.Value.Value;
when Name_Config_Spec_File_Name_Index =>
-- Attribute Config_Spec_File_Name_Index
-- ( < Language > )
Lang_Index.Config.Config_Spec_Index :=
Element.Value.Value;
when Name_Config_Spec_File_Name_Pattern =>
-- Attribute Config_Spec_File_Name_Pattern
-- (<language>)
-- (<language>)
Lang_Index.Config.Config_Spec_Pattern :=
Element.Value.Value;

14
gcc/ada/prj-proc.adb
View File

@ -1871,6 +1871,9 @@ package body Prj.Proc is
Index_Name : Name_Id :=
Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree);
Source_Index : constant Int :=
Source_Index_Of
(Current_Item, From_Project_Node_Tree);
The_Array : Array_Id;
The_Array_Element : Array_Element_Id :=
No_Array_Element;
@ -1943,12 +1946,15 @@ package body Prj.Proc is
end if;
-- Look in the list, if any, to find an element
-- with the same index.
-- with the same index and same source index.
while The_Array_Element /= No_Array_Element
and then
In_Tree.Array_Elements.Table
(In_Tree.Array_Elements.Table
(The_Array_Element).Index /= Index_Name
or else
In_Tree.Array_Elements.Table
(The_Array_Element).Src_Index /= Source_Index)
loop
The_Array_Element :=
In_Tree.Array_Elements.Table
@ -1968,9 +1974,7 @@ package body Prj.Proc is
In_Tree.Array_Elements.Table
(The_Array_Element) :=
(Index => Index_Name,
Src_Index =>
Source_Index_Of
(Current_Item, From_Project_Node_Tree),
Src_Index => Source_Index,
Index_Case_Sensitive =>
not Case_Insensitive
(Current_Item, From_Project_Node_Tree),

33
gcc/ada/prj.adb
View File

@ -679,6 +679,39 @@ package body Prj is
end if;
end Object_Name;
function Object_Name
(Source_File_Name : File_Name_Type;
Source_Index : Int;
Index_Separator : Character;
Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
is
Index_Img : constant String := Source_Index'Img;
Last : Natural;
begin
Get_Name_String (Source_File_Name);
Last := Name_Len;
while Last > 1 and then Name_Buffer (Last) /= '.' loop
Last := Last - 1;
end loop;
if Last > 1 then
Name_Len := Last - 1;
end if;
Add_Char_To_Name_Buffer (Index_Separator);
Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
if Object_File_Suffix = No_Name then
Add_Str_To_Name_Buffer (Object_Suffix);
else
Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
end if;
return Name_Find;
end Object_Name;
----------------------
-- Record_Temp_File --
----------------------

40
gcc/ada/prj.ads
View File

@ -160,7 +160,7 @@ package Prj is
end case;
end record;
-- Values for variables and array elements. Default is True if the
-- current value is the default one for the variable
-- current value is the default one for the variable.
Nil_Variable_Value : constant Variable_Value;
-- Value of a non existing variable or array element
@ -278,8 +278,8 @@ package Prj is
function Hash (Name : Name_Id) return Header_Num;
function Hash (Name : File_Name_Type) return Header_Num;
function Hash (Name : Path_Name_Type) return Header_Num;
function Hash (Project : Project_Id) return Header_Num;
-- Used for computing hash values for names put into above hash table
function Hash (Project : Project_Id) return Header_Num;
-- Used for computing hash values for names put into hash tables
type Language_Kind is (File_Based, Unit_Based);
-- Type for the kind of language. All languages are file based, except Ada
@ -433,6 +433,14 @@ package Prj is
-- The list of final switches that are required as a minimum to invoke
-- the compiler driver.
Multi_Unit_Switches : Name_List_Index := No_Name_List;
-- The switch(es) to indicate the index of a unit in a multi-source
-- file.
Multi_Unit_Object_Separator : Character := ' ';
-- The string separating the base name of a source from the index of
-- the unit in a multi-source file, in the object file name.
Path_Syntax : Path_Syntax_Kind := Host;
-- Value may be Canonical (Unix style) or Host (host syntax, for example
-- on VMS for DEC C).
@ -515,14 +523,22 @@ package Prj is
-- The template for a pragma Source_File_Name(_Project) for a specific
-- file name of a body.
Config_Spec : Name_Id := No_Name;
Config_Body_Index : Name_Id := No_Name;
-- The template for a pragma Source_File_Name(_Project) for a specific
-- file name of a spec.
-- file name of a body in a multi-source file.
Config_Body_Pattern : Name_Id := No_Name;
-- The template for a pragma Source_File_Name(_Project) for a naming
-- body pattern.
Config_Spec : Name_Id := No_Name;
-- The template for a pragma Source_File_Name(_Project) for a specific
-- file name of a spec.
Config_Spec_Index : Name_Id := No_Name;
-- The template for a pragma Source_File_Name(_Project) for a specific
-- file name of a spec in a multi-source file.
Config_Spec_Pattern : Name_Id := No_Name;
-- The template for a pragma Source_File_Name(_Project) for a naming
-- spec pattern.
@ -561,6 +577,8 @@ package Prj is
Compiler_Driver_Path => null,
Compiler_Leading_Required_Switches => No_Name_List,
Compiler_Trailing_Required_Switches => No_Name_List,
Multi_Unit_Switches => No_Name_List,
Multi_Unit_Object_Separator => ' ',
Path_Syntax => Canonical,
Object_File_Suffix => No_Name,
Object_File_Switches => No_Name_List,
@ -582,8 +600,10 @@ package Prj is
Objects_Path => No_Name,
Objects_Path_File => No_Name,
Config_Body => No_Name,
Config_Spec => No_Name,
Config_Body_Index => No_Name,
Config_Body_Pattern => No_Name,
Config_Spec => No_Name,
Config_Spec_Index => No_Name,
Config_Spec_Pattern => No_Name,
Config_File_Unique => False,
Binder_Driver => No_File,
@ -1362,6 +1382,14 @@ package Prj is
Object_File_Suffix : Name_Id := No_Name) return File_Name_Type;
-- Returns the object file name corresponding to a source file name
function Object_Name
(Source_File_Name : File_Name_Type;
Source_Index : Int;
Index_Separator : Character;
Object_File_Suffix : Name_Id := No_Name) return File_Name_Type;
-- Returns the object file name corresponding to a unit in a multi-source
-- file.
function Dependency_Name
(Source_File_Name : File_Name_Type;
Dependency : Dependency_File_Kind) return File_Name_Type;

4
gcc/ada/snames.ads-tmpl
View File

@ -1033,10 +1033,12 @@ package Snames is
Name_Compiler : constant Name_Id := N + $;
Name_Compiler_Command : constant Name_Id := N + $; -- GPR
Name_Config_Body_File_Name : constant Name_Id := N + $;
Name_Config_Body_File_Name_Index : constant Name_Id := N + $;
Name_Config_Body_File_Name_Pattern : constant Name_Id := N + $;
Name_Config_File_Switches : constant Name_Id := N + $;
Name_Config_File_Unique : constant Name_Id := N + $;
Name_Config_Spec_File_Name : constant Name_Id := N + $;
Name_Config_Spec_File_Name_Index : constant Name_Id := N + $;
Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + $;
Name_Configuration : constant Name_Id := N + $;
Name_Cross_Reference : constant Name_Id := N + $;
@ -1103,6 +1105,8 @@ package Snames is
Name_Mapping_Body_Suffix : constant Name_Id := N + $;
Name_Max_Command_Line_Length : constant Name_Id := N + $;
Name_Metrics : constant Name_Id := N + $;
Name_Multi_Unit_Object_Separator : constant Name_Id := N + $;
Name_Multi_Unit_Switches : constant Name_Id := N + $;
Name_Naming : constant Name_Id := N + $;
Name_None : constant Name_Id := N + $;
Name_Object_File_Suffix : constant Name_Id := N + $;