* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154782
138bc75d-0d04-0410-961f-
82ee72b054a4
+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.
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 --
------------------------------
type File_And_Loc is record
File_Name : File_Name_Type;
+ Index : Int := 0;
Location : Source_Ptr := No_Location;
end record;
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;
------------
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 --
------------------
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 --
------------------
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
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.
-- 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
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
"Sapath_syntax#" &
"Saobject_file_suffix#" &
"Laobject_file_switches#" &
+ "Lamulti_unit_switches#" &
+ "Samulti_unit_object_separator#" &
-- Configuration - Mapping files
"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#" &
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 :=
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;
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;
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;
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
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),
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 --
----------------------
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
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
-- 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).
-- 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.
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,
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,
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;
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 + $;
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 + $;
OSDN Git Service
