Commit f91c36dc by Arnaud Charlet

[multiple changes]

2009-06-23  Robert Dewar  <dewar@adacore.com>

	* s-strhas.adb, s-strhas.ads: Restrict to 32-bit modular types

	* s-imgdec.adb (Set_Decimal_Digits): Fix error of too many digits for
	small values

	* prj-conf.ads: Minor reformatting

	* prj-conf.adb: Minor reformatting

2009-06-23  Vasiliy Fofanov  <fofanov@adacore.com>

	* g-debpoo.adb (Dump_Gnatmem): Output dummy timestamps for allocations
	to correspond to the log format that gnatmem now expects.

2009-06-23  Vincent Celier  <celier@adacore.com>

	* prj-attr.adb: New attributes Initial_Required_Switches,
	Final_Required_Switches and Object_File_Switches
	
	* prj-nmsc.adb (Process_Compiler): Process new attributes
	Name_Final_Required_Switches, Name_Initial_Required_Switches and
	Name_Object_File_Switches.

	* prj.ads (Language_Config): New component
	Compiler_Initial_Required_Switches (replace Compiler_Required_Switches),
	Compiler_Final_Required_Switches and Object_File_Switches.

	* snames.ads-tmpl: New standard names Initial_Required_Switches,
	Final_Required_Switches and Object_File_Switches

From-SVN: r148837
parent 35262047
2009-06-23 Robert Dewar <dewar@adacore.com>
* s-strhas.adb, s-strhas.ads: Restrict to 32-bit modular types
* s-imgdec.adb (Set_Decimal_Digits): Fix error of too many digits for
small values
* prj-conf.ads: Minor reformatting
* prj-conf.adb: Minor reformatting
2009-06-23 Vasiliy Fofanov <fofanov@adacore.com>
* g-debpoo.adb (Dump_Gnatmem): Output dummy timestamps for allocations
to correspond to the log format that gnatmem now expects.
2009-06-23 Vincent Celier <celier@adacore.com>
* prj-attr.adb: New attributes Initial_Required_Switches,
Final_Required_Switches and Object_File_Switches
* prj-nmsc.adb (Process_Compiler): Process new attributes
Name_Final_Required_Switches, Name_Initial_Required_Switches and
Name_Object_File_Switches.
* prj.ads (Language_Config): New component
Compiler_Initial_Required_Switches (replace Compiler_Required_Switches),
Compiler_Final_Required_Switches and Object_File_Switches.
* snames.ads-tmpl: New standard names Initial_Required_Switches,
Final_Required_Switches and Object_File_Switches
2009-06-23 Pascal Obry <obry@adacore.com> 2009-06-23 Pascal Obry <obry@adacore.com>
* s-strhas.adb, s-strhas.ads: Minor reformatting. * s-strhas.adb, s-strhas.ads: Minor reformatting.
......
...@@ -1675,10 +1675,13 @@ package body GNAT.Debug_Pools is ...@@ -1675,10 +1675,13 @@ package body GNAT.Debug_Pools is
Actual_Size : size_t; Actual_Size : size_t;
Num_Calls : Integer; Num_Calls : Integer;
Tracebk : Tracebacks_Array_Access; Tracebk : Tracebacks_Array_Access;
Dummy_Time : Duration := 1.0;
begin begin
File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1,
File);
-- List of not deallocated blocks (see Print_Info) -- List of not deallocated blocks (see Print_Info)
...@@ -1700,6 +1703,8 @@ package body GNAT.Debug_Pools is ...@@ -1700,6 +1703,8 @@ package body GNAT.Debug_Pools is
fwrite (Current'Address, Address_Size, 1, File); fwrite (Current'Address, Address_Size, 1, File);
fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
File); File);
fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1,
File);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
File); File);
......
...@@ -173,9 +173,12 @@ package body Prj.Attr is ...@@ -173,9 +173,12 @@ package body Prj.Attr is
"Sadriver#" & "Sadriver#" &
"Larequired_switches#" & "Larequired_switches#" &
"Lainitial_required_switches#" &
"Lafinal_required_switches#" &
"Lapic_option#" & "Lapic_option#" &
"Sapath_syntax#" & "Sapath_syntax#" &
"Saobject_file_suffix#" & "Saobject_file_suffix#" &
"Laobject_file_switches#" &
-- Configuration - Mapping files -- Configuration - Mapping files
......
...@@ -79,16 +79,16 @@ package body Prj.Conf is ...@@ -79,16 +79,16 @@ package body Prj.Conf is
-- found, or null otherwise -- found, or null otherwise
function Check_Target function Check_Target
(Config_File : Prj.Project_Id; (Config_File : Prj.Project_Id;
Autoconf_Specified : Boolean; Autoconf_Specified : Boolean;
Project_Tree : Prj.Project_Tree_Ref; Project_Tree : Prj.Project_Tree_Ref;
Target : String := "") return Boolean; Target : String := "") return Boolean;
-- Check that the config file's target matches Target. -- Check that the config file's target matches Target. Target should be
-- Target should be set to the empty string when the user did not specify -- set to the empty string when the user did not specify a target. If the
-- a target. -- target in the configuration file is invalid, this function will call
-- If the target in the configuration file is invalid, this function will -- Osint.Fail to report a fatal error message and stop the program.
-- call Osint.Fail to report a fatal error message and stop the program. -- Autoconf_Specified should be set to True if the user has used
-- Autoconf_Specified should be set to True if the user has used --autoconf -- autoconf.
-------------------- --------------------
-- Add_Attributes -- -- Add_Attributes --
...@@ -118,7 +118,6 @@ package body Prj.Conf is ...@@ -118,7 +118,6 @@ package body Prj.Conf is
begin begin
Conf_Attr_Id := Conf_Decl.Attributes; Conf_Attr_Id := Conf_Decl.Attributes;
User_Attr_Id := User_Decl.Attributes; User_Attr_Id := User_Decl.Attributes;
while Conf_Attr_Id /= No_Variable loop while Conf_Attr_Id /= No_Variable loop
Conf_Attr := Conf_Attr :=
Project_Tree.Variable_Elements.Table (Conf_Attr_Id); Project_Tree.Variable_Elements.Table (Conf_Attr_Id);
...@@ -135,25 +134,22 @@ package body Prj.Conf is ...@@ -135,25 +134,22 @@ package body Prj.Conf is
Project_Tree.Variable_Elements.Table (User_Attr_Id) := Project_Tree.Variable_Elements.Table (User_Attr_Id) :=
User_Attr; User_Attr;
elsif User_Attr.Value.Kind = List and then elsif User_Attr.Value.Kind = List
Conf_Attr.Value.Values /= Nil_String and then Conf_Attr.Value.Values /= Nil_String
then then
-- List attribute declared in both the user project and the -- List attribute declared in both the user project and the
-- configuration project: prepend the user list with the -- configuration project: prepend the user list with the
-- configuration list. -- configuration list.
declare declare
Conf_List : String_List_Id := Conf_List : String_List_Id := Conf_Attr.Value.Values;
Conf_Attr.Value.Values;
Conf_Elem : String_Element; Conf_Elem : String_Element;
User_List : constant String_List_Id := User_List : constant String_List_Id :=
User_Attr.Value.Values; User_Attr.Value.Values;
New_List : String_List_Id; New_List : String_List_Id;
New_Elem : String_Element; New_Elem : String_Element;
begin begin
-- Create new list -- Create new list
String_Element_Table.Increment_Last String_Element_Table.Increment_Last
...@@ -187,7 +183,6 @@ package body Prj.Conf is ...@@ -187,7 +183,6 @@ package body Prj.Conf is
exit; exit;
else else
-- If it is not the last element in the list, add to -- If it is not the last element in the list, add to
-- new list. -- new list.
...@@ -269,10 +264,11 @@ package body Prj.Conf is ...@@ -269,10 +264,11 @@ package body Prj.Conf is
if Conf_List /= Nil_String then if Conf_List /= Nil_String then
declare declare
Link : constant String_List_Id := Link : constant String_List_Id :=
User_Array_Elem.Value.Values; User_Array_Elem.Value.Values;
Previous : String_List_Id := Nil_String; Previous : String_List_Id := Nil_String;
Next : String_List_Id; Next : String_List_Id;
begin begin
loop loop
Conf_List_Elem := Conf_List_Elem :=
...@@ -330,7 +326,6 @@ package body Prj.Conf is ...@@ -330,7 +326,6 @@ package body Prj.Conf is
(Name, (Name,
"." & Path_Separator & "." & Path_Separator &
Prefix_Path & "share" & Directory_Separator & "gpr"); Prefix_Path & "share" & Directory_Separator & "gpr");
else else
return Locate_Regular_File (Name, "."); return Locate_Regular_File (Name, ".");
end if; end if;
...@@ -346,10 +341,12 @@ package body Prj.Conf is ...@@ -346,10 +341,12 @@ package body Prj.Conf is
Project_Tree : Prj.Project_Tree_Ref; Project_Tree : Prj.Project_Tree_Ref;
Target : String := "") return Boolean Target : String := "") return Boolean
is is
Variable : constant Variable_Value := Variable : constant Variable_Value :=
Value_Of (Name_Target, Config_File.Decl.Attributes, Project_Tree); Value_Of
(Name_Target, Config_File.Decl.Attributes, Project_Tree);
Tgt_Name : Name_Id := No_Name; Tgt_Name : Name_Id := No_Name;
OK : Boolean; OK : Boolean;
begin begin
if Variable /= Nil_Variable_Value and then not Variable.Default then if Variable /= Nil_Variable_Value and then not Variable.Default then
Tgt_Name := Variable.Value; Tgt_Name := Variable.Value;
...@@ -359,7 +356,7 @@ package body Prj.Conf is ...@@ -359,7 +356,7 @@ package body Prj.Conf is
OK := not Autoconf_Specified or Tgt_Name = No_Name; OK := not Autoconf_Specified or Tgt_Name = No_Name;
else else
OK := Tgt_Name /= No_Name OK := Tgt_Name /= No_Name
and then Target = Get_Name_String (Tgt_Name); and then Target = Get_Name_String (Tgt_Name);
end if; end if;
if not OK then if not OK then
...@@ -423,7 +420,8 @@ package body Prj.Conf is ...@@ -423,7 +420,8 @@ package body Prj.Conf is
function Default_File_Name return String is function Default_File_Name return String is
Ada_RTS : constant String := Runtime_Name_For (Name_Ada); Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
Tmp : String_Access; Tmp : String_Access;
begin begin
if Target_Name /= "" then if Target_Name /= "" then
if Ada_RTS /= "" then if Ada_RTS /= "" then
...@@ -459,6 +457,7 @@ package body Prj.Conf is ...@@ -459,6 +457,7 @@ package body Prj.Conf is
function Might_Have_Sources (Project : Project_Id) return Boolean is function Might_Have_Sources (Project : Project_Id) return Boolean is
Variable : Variable_Value; Variable : Variable_Value;
begin begin
Variable := Variable :=
Value_Of Value_Of
...@@ -478,6 +477,7 @@ package body Prj.Conf is ...@@ -478,6 +477,7 @@ package body Prj.Conf is
return Variable = Nil_Variable_Value return Variable = Nil_Variable_Value
or else Variable.Default or else Variable.Default
or else Variable.Values /= Nil_String; or else Variable.Values /= Nil_String;
else else
return False; return False;
end if; end if;
...@@ -497,11 +497,11 @@ package body Prj.Conf is ...@@ -497,11 +497,11 @@ package body Prj.Conf is
Equal => "="); Equal => "=");
-- Hash table to keep the languages used in the project tree -- Hash table to keep the languages used in the project tree
IDE : constant Package_Id := IDE : constant Package_Id :=
Value_Of Value_Of
(Name_Ide, (Name_Ide,
Project.Decl.Packages, Project.Decl.Packages,
Project_Tree); Project_Tree);
Prj_Iter : Project_List; Prj_Iter : Project_List;
List : String_List_Id; List : String_List_Id;
...@@ -535,8 +535,8 @@ package body Prj.Conf is ...@@ -535,8 +535,8 @@ package body Prj.Conf is
Prj_Iter.Project.Decl.Attributes, Prj_Iter.Project.Decl.Attributes,
Project_Tree); Project_Tree);
if Variable /= Nil_Variable_Value and then if Variable /= Nil_Variable_Value
not Variable.Default and then not Variable.Default
then then
Get_Name_String (Variable.Value); Get_Name_String (Variable.Value);
To_Lower (Name_Buffer (1 .. Name_Len)); To_Lower (Name_Buffer (1 .. Name_Len));
...@@ -574,16 +574,15 @@ package body Prj.Conf is ...@@ -574,16 +574,15 @@ package body Prj.Conf is
Name := Language_Htable.Get_First; Name := Language_Htable.Get_First;
Count := 0; Count := 0;
while Name /= No_Name loop while Name /= No_Name loop
Count := Count + 1; Count := Count + 1;
Name := Language_Htable.Get_Next; Name := Language_Htable.Get_Next;
end loop; end loop;
Result := new String_List (1 .. Count); Result := new String_List (1 .. Count);
Count := 1;
Name := Language_Htable.Get_First;
Count := 1;
Name := Language_Htable.Get_First;
while Name /= No_Name loop while Name /= No_Name loop
-- Check if IDE'Compiler_Command is declared for the language. -- Check if IDE'Compiler_Command is declared for the language.
-- If it is, use its value to invoke gprconfig. -- If it is, use its value to invoke gprconfig.
...@@ -645,10 +644,14 @@ package body Prj.Conf is ...@@ -645,10 +644,14 @@ package body Prj.Conf is
procedure Do_Autoconf is procedure Do_Autoconf is
Obj_Dir : constant Variable_Value := Obj_Dir : constant Variable_Value :=
Value_Of (Name_Object_Dir, Project.Decl.Attributes, Project_Tree); Value_Of
(Name_Object_Dir,
Project.Decl.Attributes,
Project_Tree);
Gprconfig_Path : String_Access; Gprconfig_Path : String_Access;
Success : Boolean; Success : Boolean;
begin begin
Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
...@@ -892,7 +895,7 @@ package body Prj.Conf is ...@@ -892,7 +895,7 @@ package body Prj.Conf is
Prj.Initialize (Project_Tree); Prj.Initialize (Project_Tree);
Prj.Tree.Initialize (Project_Node_Tree); Prj.Tree.Initialize (Project_Node_Tree);
Main_Project := No_Project; Main_Project := No_Project;
Automatically_Generated := False; Automatically_Generated := False;
Prj.Part.Parse Prj.Part.Parse
...@@ -986,7 +989,6 @@ package body Prj.Conf is ...@@ -986,7 +989,6 @@ package body Prj.Conf is
begin begin
Proj := Project_Tree.Projects; Proj := Project_Tree.Projects;
while Proj /= null loop while Proj /= null loop
if Proj.Project /= Config_File then if Proj.Project /= Config_File then
User_Decl := Proj.Project.Decl; User_Decl := Proj.Project.Decl;
......
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- The following package manipulates the configuration files. -- The following package manipulates the configuration files
with Prj.Tree; with Prj.Tree;
...@@ -35,8 +35,8 @@ package Prj.Conf is ...@@ -35,8 +35,8 @@ package Prj.Conf is
Project_Tree : Prj.Project_Tree_Ref); Project_Tree : Prj.Project_Tree_Ref);
-- Hook called after the config file has been parsed. This lets the -- Hook called after the config file has been parsed. This lets the
-- application do last minute changes to it (GPS uses this to add the -- application do last minute changes to it (GPS uses this to add the
-- default naming schemes for instance). At that point, the config file has -- default naming schemes for instance). At that point, the config file
-- not been applied to the project yet. -- has not been applied to the project yet.
procedure Parse_Project_And_Apply_Config procedure Parse_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id; (Main_Project : out Prj.Project_Id;
...@@ -55,6 +55,7 @@ package Prj.Conf is ...@@ -55,6 +55,7 @@ package Prj.Conf is
On_Load_Config : Config_File_Hook := null); On_Load_Config : Config_File_Hook := null);
-- Find the main configuration project and parse the project tree rooted at -- Find the main configuration project and parse the project tree rooted at
-- this configuration project. -- this configuration project.
--
-- If the processing fails, Main_Project is set to No_Project. If the error -- If the processing fails, Main_Project is set to No_Project. If the error
-- happend while parsing the project itself (ie creating the tree), -- happend while parsing the project itself (ie creating the tree),
-- User_Project_Node is also set to Empty_Node -- User_Project_Node is also set to Empty_Node
...@@ -63,6 +64,7 @@ package Prj.Conf is ...@@ -63,6 +64,7 @@ package Prj.Conf is
-- If this is the case, the config file might be (re)generated, as -- If this is the case, the config file might be (re)generated, as
-- appropriate, to match languages and target if the one specified doesn't -- appropriate, to match languages and target if the one specified doesn't
-- already match. -- already match.
--
-- Normalized_Hostname is the host on which gprbuild is returned, -- Normalized_Hostname is the host on which gprbuild is returned,
-- normalized so that we can more easily compare it with what is stored in -- normalized so that we can more easily compare it with what is stored in
-- configuration files. It is used when the target is unspecified, although -- configuration files. It is used when the target is unspecified, although
...@@ -90,13 +92,16 @@ package Prj.Conf is ...@@ -90,13 +92,16 @@ package Prj.Conf is
-- default configuration file is found, a new one will be automatically -- default configuration file is found, a new one will be automatically
-- generated if Allow_Automatic_Generation is true (otherwise an error -- generated if Allow_Automatic_Generation is true (otherwise an error
-- reported to the user via Osint.Fail). -- reported to the user via Osint.Fail).
--
-- On exit, Configuration_Project_Path is never null (if none could be -- On exit, Configuration_Project_Path is never null (if none could be
-- found, Os.Fail was called and the program exited anyway). -- found, Os.Fail was called and the program exited anyway).
--
-- The choice and generation of a configuration file depends on several -- The choice and generation of a configuration file depends on several
-- attributes of the user's project file (given by the Project argument), -- attributes of the user's project file (given by the Project argument),
-- like the list of languages that must be supported. Project must -- like the list of languages that must be supported. Project must
-- therefore have been partially processed (phase one of the processing -- therefore have been partially processed (phase one of the processing
-- only). -- only).
--
-- Config_File_Name should be set to the name of the config file specified -- Config_File_Name should be set to the name of the config file specified
-- by the user (either through gprbuild's --config or --autoconf switches). -- by the user (either through gprbuild's --config or --autoconf switches).
-- In the latter case, Autoconf_Specified should be set to true, to -- In the latter case, Autoconf_Specified should be set to true, to
...@@ -104,6 +109,7 @@ package Prj.Conf is ...@@ -104,6 +109,7 @@ package Prj.Conf is
-- and languages. This name can either be an absolute path, or the a base -- and languages. This name can either be an absolute path, or the a base
-- name that will be searched in the default config file directories (which -- name that will be searched in the default config file directories (which
-- depends on the installation path for the tools). -- depends on the installation path for the tools).
--
-- Target_Name is used to chose among several possibilities -- Target_Name is used to chose among several possibilities
-- the configuration file that will be used. -- the configuration file that will be used.
-- --
......
...@@ -622,7 +622,7 @@ package body Prj.Nmsc is ...@@ -622,7 +622,7 @@ package body Prj.Nmsc is
Suffix : File_Name_Type) return Boolean Suffix : File_Name_Type) return Boolean
is is
begin begin
if Suffix = No_File then if Suffix = No_File or else Suffix = Empty_File then
return False; return False;
end if; end if;
...@@ -1427,9 +1427,18 @@ package body Prj.Nmsc is ...@@ -1427,9 +1427,18 @@ package body Prj.Nmsc is
Lang_Index.Config.Compiler_Driver := Lang_Index.Config.Compiler_Driver :=
File_Name_Type (Element.Value.Value); File_Name_Type (Element.Value.Value);
when Name_Required_Switches => when Name_Required_Switches |
Name_Initial_Required_Switches =>
Put (Into_List =>
Lang_Index.Config.
Compiler_Initial_Required_Switches,
From_List => Element.Value.Values,
In_Tree => In_Tree);
when Name_Final_Required_Switches =>
Put (Into_List => Put (Into_List =>
Lang_Index.Config.Compiler_Required_Switches, Lang_Index.Config.
Compiler_Final_Required_Switches,
From_List => Element.Value.Values, From_List => Element.Value.Values,
In_Tree => In_Tree); In_Tree => In_Tree);
...@@ -1460,6 +1469,12 @@ package body Prj.Nmsc is ...@@ -1460,6 +1469,12 @@ package body Prj.Nmsc is
Element.Value.Value; Element.Value.Value;
end if; end if;
when Name_Object_File_Switches =>
Put (Into_List =>
Lang_Index.Config.Object_File_Switches,
From_List => Element.Value.Values,
In_Tree => In_Tree);
when Name_Pic_Option => when Name_Pic_Option =>
-- Attribute Compiler_Pic_Option (<language>) -- Attribute Compiler_Pic_Option (<language>)
...@@ -4112,28 +4127,6 @@ package body Prj.Nmsc is ...@@ -4112,28 +4127,6 @@ package body Prj.Nmsc is
end if; end if;
end; end;
declare
Current : Array_Element_Id;
Element : Array_Element;
begin
Current := Project.Naming.Spec_Suffix;
while Current /= No_Array_Element loop
Element := In_Tree.Array_Elements.Table (Current);
Get_Name_String (Element.Value.Value);
if Name_Len = 0 then
Error_Msg
(Project, In_Tree,
"Spec_Suffix cannot be empty",
Element.Value.Location);
end if;
In_Tree.Array_Elements.Table (Current) := Element;
Current := Element.Next;
end loop;
end;
-- Check Body_Suffix -- Check Body_Suffix
declare declare
...@@ -4194,28 +4187,6 @@ package body Prj.Nmsc is ...@@ -4194,28 +4187,6 @@ package body Prj.Nmsc is
end if; end if;
end; end;
declare
Current : Array_Element_Id;
Element : Array_Element;
begin
Current := Project.Naming.Body_Suffix;
while Current /= No_Array_Element loop
Element := In_Tree.Array_Elements.Table (Current);
Get_Name_String (Element.Value.Value);
if Name_Len = 0 then
Error_Msg
(Project, In_Tree,
"Body_Suffix cannot be empty",
Element.Value.Location);
end if;
In_Tree.Array_Elements.Table (Current) := Element;
Current := Element.Next;
end loop;
end;
-- Get the exceptions, if any -- Get the exceptions, if any
Project.Naming.Specification_Exceptions := Project.Naming.Specification_Exceptions :=
...@@ -6421,19 +6392,21 @@ package body Prj.Nmsc is ...@@ -6421,19 +6392,21 @@ package body Prj.Nmsc is
Suffix_Str : constant String := Get_Name_String (Suffix); Suffix_Str : constant String := Get_Name_String (Suffix);
begin begin
if Suffix_Str'Length = 0 or else Index (Suffix_Str, ".") = 0 then if Suffix_Str'Length = 0 then
return False;
elsif Index (Suffix_Str, ".") = 0 then
return True; return True;
end if; end if;
-- If dot replacement is a single dot, and first character of suffix is -- Case of dot replacement is a single dot, and first character of
-- also a dot -- suffix is also a dot.
if Get_Name_String (Dot_Replacement) = "." if Get_Name_String (Dot_Replacement) = "."
and then Suffix_Str (Suffix_Str'First) = '.' and then Suffix_Str (Suffix_Str'First) = '.'
then then
for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
-- If there is another dot -- Case of following dot
if Suffix_Str (Index) = '.' then if Suffix_Str (Index) = '.' then
...@@ -6784,7 +6757,7 @@ package body Prj.Nmsc is ...@@ -6784,7 +6757,7 @@ package body Prj.Nmsc is
(Source_List_File.Kind = Single, (Source_List_File.Kind = Single,
"Source_List_File is not a single string"); "Source_List_File is not a single string");
-- If the user has specified a Sources attribute -- If the user has specified a Source_Files attribute
if not Sources.Default then if not Sources.Default then
if not Source_List_File.Default then if not Source_List_File.Default then
......
...@@ -419,15 +419,25 @@ package Prj is ...@@ -419,15 +419,25 @@ package Prj is
Compiler_Driver_Path : String_Access := null; Compiler_Driver_Path : String_Access := null;
-- The path name of the executable for the compiler of the language -- The path name of the executable for the compiler of the language
Compiler_Required_Switches : Name_List_Index := No_Name_List; Compiler_Initial_Required_Switches : Name_List_Index := No_Name_List;
-- The list of switches that are required as a minimum to invoke the -- The list of initial switches that are required as a minimum to invoke
-- compiler driver. -- the compiler driver.
Compiler_Final_Required_Switches : Name_List_Index := No_Name_List;
-- The list of final switches that are required as a minimum to invoke
-- the compiler driver.
Path_Syntax : Path_Syntax_Kind := Host; Path_Syntax : Path_Syntax_Kind := Host;
-- Value may be Canonical (Unix style) or Host (host syntax, for example -- Value may be Canonical (Unix style) or Host (host syntax, for example
-- on VMS for DEC C). -- on VMS for DEC C).
Object_File_Suffix : Name_Id := No_Name; Object_File_Suffix : Name_Id := No_Name;
-- Optional alternate object file suffix
Object_File_Switches : Name_List_Index := No_Name_List;
-- Optional object file switches. When this is defined, the switches
-- are used to specify the object file. The object file name is appended
-- to the last switch in the list. Example: ("-o", "").
Compilation_PIC_Option : Name_List_Index := No_Name_List; Compilation_PIC_Option : Name_List_Index := No_Name_List;
-- The option(s) to compile a source in Position Independent Code for -- The option(s) to compile a source in Position Independent Code for
...@@ -543,9 +553,11 @@ package Prj is ...@@ -543,9 +553,11 @@ package Prj is
Include_Compatible_Languages => No_Name_List, Include_Compatible_Languages => No_Name_List,
Compiler_Driver => No_File, Compiler_Driver => No_File,
Compiler_Driver_Path => null, Compiler_Driver_Path => null,
Compiler_Required_Switches => No_Name_List, Compiler_Initial_Required_Switches => No_Name_List,
Compiler_Final_Required_Switches => No_Name_List,
Path_Syntax => Canonical, Path_Syntax => Canonical,
Object_File_Suffix => No_Name, Object_File_Suffix => No_Name,
Object_File_Switches => No_Name_List,
Compilation_PIC_Option => No_Name_List, Compilation_PIC_Option => No_Name_List,
Object_Generated => True, Object_Generated => True,
Objects_Linked => True, Objects_Linked => True,
......
...@@ -101,13 +101,14 @@ package body System.Img_Dec is ...@@ -101,13 +101,14 @@ package body System.Img_Dec is
Expon : Integer; Expon : Integer;
-- Integer value of exponent -- Integer value of exponent
procedure Round (N : Natural); procedure Round (N : Integer);
-- Round the number in Digs. N is the position of the last digit to be -- Round the number in Digs. N is the position of the last digit to be
-- retained in the rounded position (rounding is based on Digs (N + 1) -- retained in the rounded position (rounding is based on Digs (N + 1)
-- FD, LD, ND are reset as necessary if required. Note that if the -- FD, LD, ND are reset as necessary if required. Note that if the
-- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
-- placed in the sign position as a result of the rounding, this is -- placed in the sign position as a result of the rounding, this is
-- the case in which FD is adjusted. -- the case in which FD is adjusted. The call to Round has no effect
-- if N is outside the range FD .. LD.
procedure Set (C : Character); procedure Set (C : Character);
pragma Inline (Set); pragma Inline (Set);
...@@ -131,11 +132,11 @@ package body System.Img_Dec is ...@@ -131,11 +132,11 @@ package body System.Img_Dec is
-- Round -- -- Round --
----------- -----------
procedure Round (N : Natural) is procedure Round (N : Integer) is
D : Character; D : Character;
begin begin
-- Nothing to do if rounding at or past last digit -- Nothing to do if rounding past the last digit we have
if N >= LD then if N >= LD then
return; return;
...@@ -318,9 +319,27 @@ package body System.Img_Dec is ...@@ -318,9 +319,27 @@ package body System.Img_Dec is
Set_Blanks_And_Sign (Fore - 1); Set_Blanks_And_Sign (Fore - 1);
Set ('0'); Set ('0');
Set ('.'); Set ('.');
Set_Zeroes (-Digits_Before_Point);
Set_Digits (FD, LD); declare
Set_Zeroes (Digits_After_Point - Scale); DA : Natural := Digits_After_Point;
-- Digits remaining to output after point
LZ : constant Integer :=
Integer'Max (0, Integer'Min (DA, -Digits_Before_Point));
-- Number of leading zeroes after point
begin
Set_Zeroes (LZ);
DA := DA - LZ;
if DA < ND then
Set_Digits (FD, FD + DA - 1);
else
Set_Digits (FD, LD);
Set_Zeroes (DA - ND);
end if;
end;
-- At least one digit before point in input -- At least one digit before point in input
......
...@@ -31,9 +31,8 @@ ...@@ -31,9 +31,8 @@
package body System.String_Hash is package body System.String_Hash is
-- Compute a hash value for a key. The approach here is follows -- Compute a hash value for a key. The approach here is follows the
-- the algorithm used in GNU Awk and the ndbm substitute SDBM by -- algorithm used in GNU Awk and the ndbm substitute SDBM by Ozan Yigit.
-- Ozan Yigit.
---------- ----------
-- Hash -- -- Hash --
...@@ -41,6 +40,12 @@ package body System.String_Hash is ...@@ -41,6 +40,12 @@ package body System.String_Hash is
function Hash (Key : Key_Type) return Hash_Type is function Hash (Key : Key_Type) return Hash_Type is
pragma Compile_Time_Error
(Hash_Type'Modulus /= 2 ** 32
or else Hash_Type'First /= 0
or else Hash_Type'Last /= 2 ** 32 - 1,
"Hash_Type must be 32-bit modular with range 0 .. 2**32-1");
function Shift_Left function Shift_Left
(Value : Hash_Type; (Value : Hash_Type;
Amount : Natural) return Hash_Type; Amount : Natural) return Hash_Type;
......
...@@ -29,13 +29,14 @@ ...@@ -29,13 +29,14 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package provides a generic hashing function over strings, -- This package provides a generic hashing function over strings, suitable for
-- suitable for use with a string keyed hash table. -- use with a string keyed hash table. In particular, it is the basis for the
-- string hash functions in Ada.Containers.
-- --
-- The strategy used here is not appropriate for applications that -- The algorithm used here is not appropriate for applications that require
-- require cryptographically strong hashes, or for application which -- cryptographically strong hashes, or for application which wish to use very
-- wish to use very wide hash values as pseudo unique identifiers. In -- wide hash values as pseudo unique identifiers. In such cases please refer
-- such cases please refer to GNAT.SHA1 and GNAT.MD5. -- to GNAT.SHA1 and GNAT.MD5.
package System.String_Hash is package System.String_Hash is
pragma Pure; pragma Pure;
...@@ -48,7 +49,9 @@ package System.String_Hash is ...@@ -48,7 +49,9 @@ package System.String_Hash is
-- The string type to use as a hash key -- The string type to use as a hash key
type Hash_Type is mod <>; type Hash_Type is mod <>;
-- The type to be returned as a hash value -- The type to be returned as a hash value. This must be a 32-bit
-- unsigned type with full range 0 .. 2**32-1, no other type is allowed
-- for this instantiation (checked in the body by Compile_Time_Error).
function Hash (Key : Key_Type) return Hash_Type; function Hash (Key : Key_Type) return Hash_Type;
pragma Inline (Hash); pragma Inline (Hash);
......
...@@ -1047,6 +1047,7 @@ package Snames is ...@@ -1047,6 +1047,7 @@ package Snames is
Name_Executable_Suffix : constant Name_Id := N + $; Name_Executable_Suffix : constant Name_Id := N + $;
Name_Extends : constant Name_Id := N + $; Name_Extends : constant Name_Id := N + $;
Name_Externally_Built : constant Name_Id := N + $; Name_Externally_Built : constant Name_Id := N + $;
Name_Final_Required_Switches : constant Name_Id := N + $;
Name_Finder : constant Name_Id := N + $; Name_Finder : constant Name_Id := N + $;
Name_Global_Compilation_Switches : constant Name_Id := N + $; Name_Global_Compilation_Switches : constant Name_Id := N + $;
Name_Global_Configuration_Pragmas : constant Name_Id := N + $; Name_Global_Configuration_Pragmas : constant Name_Id := N + $;
...@@ -1062,6 +1063,7 @@ package Snames is ...@@ -1062,6 +1063,7 @@ package Snames is
Name_Include_Path : constant Name_Id := N + $; Name_Include_Path : constant Name_Id := N + $;
Name_Include_Path_File : constant Name_Id := N + $; Name_Include_Path_File : constant Name_Id := N + $;
Name_Inherit_Source_Path : constant Name_Id := N + $; Name_Inherit_Source_Path : constant Name_Id := N + $;
Name_Initial_Required_Switches : constant Name_Id := N + $;
Name_Languages : constant Name_Id := N + $; Name_Languages : constant Name_Id := N + $;
Name_Library : constant Name_Id := N + $; Name_Library : constant Name_Id := N + $;
Name_Library_Ali_Dir : constant Name_Id := N + $; Name_Library_Ali_Dir : constant Name_Id := N + $;
...@@ -1099,6 +1101,7 @@ package Snames is ...@@ -1099,6 +1101,7 @@ package Snames is
Name_Naming : constant Name_Id := N + $; Name_Naming : constant Name_Id := N + $;
Name_None : constant Name_Id := N + $; Name_None : constant Name_Id := N + $;
Name_Object_File_Suffix : constant Name_Id := N + $; Name_Object_File_Suffix : constant Name_Id := N + $;
Name_Object_File_Switches : constant Name_Id := N + $;
Name_Object_Generated : constant Name_Id := N + $; Name_Object_Generated : constant Name_Id := N + $;
Name_Object_List : constant Name_Id := N + $; Name_Object_List : constant Name_Id := N + $;
Name_Objects_Linked : constant Name_Id := N + $; Name_Objects_Linked : constant Name_Id := N + $;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment