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

[multiple changes] 

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* prj-part.adb, prj-part.ads, prj-makr.adb, prj-pars.adb, prj-conf.adb,
	prj-env.adb (Prj.Part.Parse): change parameter Always_Errout_Finalize
	to Errout_Handling.

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* prj-dect.adb (Parse_Attribute_Declaration): make sure we can use
	"external" as an attribute name in aggregate projects.

2011-08-03  Jose Ruiz  <ruiz@adacore.com>

	* s-taprop-vxworks.adb: (Create_Task, Initialize): Ada 2012 pragma CPU
	uses CPU numbers starting 1, while VxWorks uses CPU numbers starting
	from 0, so we need to adjust.

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* prj-proc.adb, prj-ext.adb, prj-ext.ads, makeutl.adb, prj-tree.adb,
	prj-tree.ads, gnatcmd.adb, clean.adb (External_References): new type.

From-SVN: r177244
This commit is contained in:
Arnaud Charlet 2011-08-03 11:21:55 +02:00
parent c4d67e2d73
commit c0e538ad80
16 changed files with 274 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/ChangeLog
View File

@ -1,3 +1,25 @@
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj-part.adb, prj-part.ads, prj-makr.adb, prj-pars.adb, prj-conf.adb,
prj-env.adb (Prj.Part.Parse): change parameter Always_Errout_Finalize
to Errout_Handling.
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj-dect.adb (Parse_Attribute_Declaration): make sure we can use
"external" as an attribute name in aggregate projects.
2011-08-03 Jose Ruiz <ruiz@adacore.com>
* s-taprop-vxworks.adb: (Create_Task, Initialize): Ada 2012 pragma CPU
uses CPU numbers starting 1, while VxWorks uses CPU numbers starting
from 0, so we need to adjust.
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-ext.adb, prj-ext.ads, makeutl.adb, prj-tree.adb,
prj-tree.ads, gnatcmd.adb, clean.adb (External_References): new type.
2011-08-03 Yannick Moy <moy@adacore.com>
* sem_ch6.adb (New_Overloaded_Entity): only issue error for SPARK

2
gcc/ada/clean.adb
View File

@ -1886,7 +1886,7 @@ package body Clean is
if OK then
Prj.Ext.Add
(Project_Node_Tree,
(Project_Node_Tree.External,
External_Name =>
Ext_Asgn (Start .. Equal_Pos - 1),
Value =>

2
gcc/ada/gnatcmd.adb
View File

@ -1822,7 +1822,7 @@ begin
if Equal_Pos >= Argv'First + 3
and then Equal_Pos /= Argv'Last
then
Add (Project_Node_Tree,
Add (Project_Node_Tree.External,
External_Name =>
Argv (Argv'First + 2 .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Argv'Last));

4
gcc/ada/makeutl.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2011, 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- --
@ -724,7 +724,7 @@ package body Makeutl is
end if;
return Prj.Ext.Check
(Tree => Tree,
(Self => Tree.External,
Declaration => Argv (Start .. Finish));
end Is_External_Assignment;

4
gcc/ada/prj-conf.adb
View File

@ -1119,7 +1119,7 @@ package body Prj.Conf is
(In_Tree => Project_Node_Tree,
Project => Config_Project_Node,
Project_File_Name => Config_File_Path.all,
Always_Errout_Finalize => False,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => True,
@ -1212,7 +1212,7 @@ package body Prj.Conf is
(In_Tree => Project_Node_Tree,
Project => User_Project_Node,
Project_File_Name => Project_File_Name,
Always_Errout_Finalize => False,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => False,

9
gcc/ada/prj-dect.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2011, 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- --
@ -494,13 +494,18 @@ package body Prj.Dect is
Scan (In_Tree);
-- Body may be an attribute name
-- Body or External may be an attribute name
if Token = Tok_Body then
Token := Tok_Identifier;
Token_Name := Snames.Name_Body;
end if;
if Token = Tok_External then
Token := Tok_Identifier;
Token_Name := Snames.Name_External;
end if;
Expect (Tok_Identifier, "identifier");
Process_Attribute_Name;
Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);

146
gcc/ada/prj-ext.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2000-2011, 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- --
@ -23,31 +23,65 @@
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Osint; use Osint;
with Prj.Tree; use Prj.Tree;
package body Prj.Ext is
----------------
-- Initialize --
----------------
procedure Initialize
(Self : out External_References;
Copy_From : External_References := No_External_Refs)
is
N : Name_To_Name_Ptr;
N2 : Name_To_Name_Ptr;
begin
if Self.Refs = null then
Self.Refs := new Name_To_Name_HTable.Instance;
if Copy_From.Refs /= null then
N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
while N /= null loop
N2 := new Name_To_Name;
N2.Key := N.Key;
N2.Value := N.Value;
Name_To_Name_HTable.Set (Self.Refs.all, N2);
N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
end loop;
end if;
end if;
end Initialize;
---------
-- Add --
---------
procedure Add
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
External_Name : String;
Value : String)
is
The_Key : Name_Id;
The_Value : Name_Id;
N : Name_To_Name_Ptr;
begin
N := new Name_To_Name;
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
The_Value := Name_Find;
N.Value := Name_Find;
Name_Len := External_Name'Length;
Name_Buffer (1 .. Name_Len) := External_Name;
Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
The_Key := Name_Find;
Name_To_Name_HTable.Set (Tree.External_References, The_Key, The_Value);
N.Key := Name_Find;
if Current_Verbosity = High then
Debug_Output ("Add (" & External_Name & ") is", N.Value);
end if;
Name_To_Name_HTable.Set (Self.Refs.all, N);
end Add;
-----------
@ -55,7 +89,7 @@ package body Prj.Ext is
-----------
function Check
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
Declaration : String) return Boolean
is
begin
@ -63,7 +97,7 @@ package body Prj.Ext is
if Declaration (Equal_Pos) = '=' then
exit when Equal_Pos = Declaration'First;
Add
(Tree => Tree,
(Self => Self,
External_Name =>
Declaration (Declaration'First .. Equal_Pos - 1),
Value =>
@ -79,9 +113,12 @@ package body Prj.Ext is
-- Reset --
-----------
procedure Reset (Tree : Prj.Tree.Project_Node_Tree_Ref) is
procedure Reset (Self : External_References) is
begin
Name_To_Name_HTable.Reset (Tree.External_References);
if Self.Refs /= null then
Debug_Output ("Reset external references");
Name_To_Name_HTable.Reset (Self.Refs.all);
end if;
end Reset;
--------------
@ -89,23 +126,26 @@ package body Prj.Ext is
--------------
function Value_Of
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
External_Name : Name_Id;
With_Default : Name_Id := No_Name)
return Name_Id
is
The_Value : Name_Id;
Name : String := Get_Name_String (External_Name);
Value : Name_To_Name_Ptr;
Val : Name_Id;
Name : String := Get_Name_String (External_Name);
begin
Canonical_Case_Env_Var_Name (Name);
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
The_Value :=
Name_To_Name_HTable.Get (Tree.External_References, Name_Find);
if The_Value /= No_Name then
return The_Value;
if Self.Refs /= null then
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
if Value /= null then
return Value.Value;
end if;
end if;
-- Find if it is an environment, if it is, put value in the hash table
@ -117,17 +157,73 @@ package body Prj.Ext is
if Env_Value /= null and then Env_Value'Length > 0 then
Name_Len := Env_Value'Length;
Name_Buffer (1 .. Name_Len) := Env_Value.all;
The_Value := Name_Find;
Name_To_Name_HTable.Set
(Tree.External_References, External_Name, The_Value);
Val := Name_Find;
if Current_Verbosity = High then
Debug_Output ("Value_Of (" & Get_Name_String (External_Name)
& ") is", Val);
end if;
if Self.Refs /= null then
Value := new Name_To_Name;
Value.Key := External_Name;
Value.Value := Val;
Name_To_Name_HTable.Set (Self.Refs.all, Value);
end if;
Free (Env_Value);
return The_Value;
return Val;
else
if Current_Verbosity = High then
Debug_Output ("Value_Of (" & Get_Name_String (External_Name)
& ") is default", With_Default);
end if;
Free (Env_Value);
return With_Default;
end if;
end;
end Value_Of;
----------
-- Free --
----------
procedure Free (Self : in out External_References) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Name_To_Name_HTable.Instance, Instance_Access);
begin
if Self.Refs /= null then
Reset (Self);
Unchecked_Free (Self.Refs);
end if;
end Free;
--------------
-- Set_Next --
--------------
procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
begin
E.Next := Next;
end Set_Next;
----------
-- Next --
----------
function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
begin
return E.Next;
end Next;
-------------
-- Get_Key --
-------------
function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
begin
return E.Key;
end Get_Key;
end Prj.Ext;

69
gcc/ada/prj-ext.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2000-2011, 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- --
@ -26,7 +26,7 @@
-- Subprograms to set, get and cache external references, to be used as
-- External functions in project files.
with Prj.Tree;
with GNAT.Dynamic_HTables;
package Prj.Ext is
@ -42,27 +42,84 @@ package Prj.Ext is
-- trees are loaded in parallel we can have different scenarios (or even
-- load the same tree twice and see different views of it).
type External_References is private;
No_External_Refs : constant External_References;
procedure Initialize
(Self : out External_References;
Copy_From : External_References := No_External_Refs);
-- Initialize Self, and copy all values from Copy_From if needed.
-- This has no effect if Self was already initialized.
procedure Free (Self : in out External_References);
-- Free memory used by Self
procedure Add
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
External_Name : String;
Value : String);
-- Add an external reference (or modify an existing one)
function Value_Of
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
External_Name : Name_Id;
With_Default : Name_Id := No_Name)
return Name_Id;
-- Get the value of an external reference, and cache it for future uses
function Check
(Tree : Prj.Tree.Project_Node_Tree_Ref;
(Self : External_References;
Declaration : String) return Boolean;
-- Check that an external declaration <external>=<value> is correct.
-- If it is correct, the external reference is Added.
procedure Reset (Tree : Prj.Tree.Project_Node_Tree_Ref);
procedure Reset (Self : External_References);
-- Clear the internal data structure that stores the external references
-- and free any allocated memory.
private
-- Use a Static_HTable, not a Simple_HTable.
-- The issue is that we need to be able to copy the contents of the table
-- (in Initialize), but this isn't doable for Simple_HTable for which
-- iterators do not return the key.
type Name_To_Name;
type Name_To_Name_Ptr is access all Name_To_Name;
type Name_To_Name is record
Key : Name_Id;
Value : Name_Id;
Next : Name_To_Name_Ptr;
end record;
procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr);
function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr;
function Get_Key (E : Name_To_Name_Ptr) return Name_Id;
package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Static_HTable
(Header_Num => Header_Num,
Element => Name_To_Name,
Elmt_Ptr => Name_To_Name_Ptr,
Null_Ptr => null,
Set_Next => Set_Next,
Next => Next,
Key => Name_Id,
Get_Key => Get_Key,
Hash => Hash,
Equal => "=");
-- General type for htables associating name_id to name_id. This is in
-- particular used to store the values of external references.
type Instance_Access is access all Name_To_Name_HTable.Instance;
type External_References is record
Refs : Instance_Access;
-- External references are stored in this hash table (and manipulated
-- through subprogrames in prj-ext.ads). External references are
-- project-tree specific so that one can load the same tree twice but
-- have two views of it, for instance.
end record;
No_External_Refs : constant External_References := (Refs => null);
end Prj.Ext;

2
gcc/ada/prj-makr.adb
View File

@ -863,7 +863,7 @@ package body Prj.Makr is
(In_Tree => Tree,
Project => Project_Node,
Project_File_Name => Output_Name.all,
Always_Errout_Finalize => False,
Errout_Handling => Part.Finalize_If_Error,
Store_Comments => True,
Is_Config_File => False,
Flags => Flags,

2
gcc/ada/prj-pars.adb
View File

@ -72,7 +72,7 @@ package body Prj.Pars is
(In_Tree => Project_Node_Tree,
Project => Project_Node,
Project_File_Name => Project_File_Name,
Always_Errout_Finalize => False,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Dir,
Flags => Flags,

26
gcc/ada/prj-part.adb
View File

@ -443,7 +443,7 @@ package body Prj.Part is
(In_Tree : Project_Node_Tree_Ref;
Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
Errout_Handling : Errout_Mode := Always_Finalize;
Packages_To_Check : String_List_Access := All_Packages;
Store_Comments : Boolean := False;
Current_Directory : String := "";
@ -477,7 +477,10 @@ package body Prj.Part is
Path => Path_Name_Id);
Free (Real_Project_File_Name);
Prj.Err.Initialize;
if Errout_Handling /= Never_Finalize then
Prj.Err.Initialize;
end if;
Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
@ -607,13 +610,22 @@ package body Prj.Part is
Project := Empty_Node;
end if;
if No (Project) or else Always_Errout_Finalize then
Prj.Err.Finalize;
case Errout_Handling is
when Always_Finalize =>
Prj.Err.Finalize;
-- Reinitialize to avoid duplicate warnings later on
-- Reinitialize to avoid duplicate warnings later on
Prj.Err.Initialize;
Prj.Err.Initialize;
end if;
when Finalize_If_Error =>
if No (Project) then
Prj.Err.Finalize;
Prj.Err.Initialize;
end if;
when Never_Finalize =>
null;
end case;
exception
when X : others =>

10
gcc/ada/prj-part.ads
View File

@ -29,11 +29,19 @@ with Prj.Tree; use Prj.Tree;
package Prj.Part is
type Errout_Mode is
(Always_Finalize,
Finalize_If_Error,
Never_Finalize);
-- Whether Parse should call Errout.Finalize (which prints the error
-- messages on stdout). When Never_Finalize is used, Errout is not reset
-- either at the beginning of Parse.
procedure Parse
(In_Tree : Project_Node_Tree_Ref;
Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
Errout_Handling : Errout_Mode := Always_Finalize;
Packages_To_Check : String_List_Access := All_Packages;
Store_Comments : Boolean := False;
Current_Directory : String := "";

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

@ -1065,7 +1065,7 @@ package body Prj.Proc is
if Ext_List then
Value :=
Prj.Ext.Value_Of
(From_Project_Node_Tree, Name, No_Name);
(From_Project_Node_Tree.External, Name, No_Name);
if Value /= No_Name then
declare
@ -1171,7 +1171,7 @@ package body Prj.Proc is
Value :=
Prj.Ext.Value_Of
(From_Project_Node_Tree, Name, Default);
(From_Project_Node_Tree.External, Name, Default);
if Value = No_Name then
if not Quiet_Output then

12
gcc/ada/prj-tree.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2011, 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- --
@ -988,8 +988,12 @@ package body Prj.Tree is
Projects_Htable.Reset (Tree.Projects_HT);
-- Do not reset the external references, in case we are reloading a
-- project, since we want to preserve the current environment
-- Name_To_Name_HTable.Reset (Tree.External_References);
-- project, since we want to preserve the current environment.
-- But we still need to ensure that the external references are properly
-- initialized.
Prj.Ext.Initialize (Tree.External);
-- Prj.Ext.Reset (Tree.External);
end Initialize;
----------
@ -1003,7 +1007,7 @@ package body Prj.Tree is
if Proj /= null then
Project_Node_Table.Free (Proj.Project_Nodes);
Projects_Htable.Reset (Proj.Projects_HT);
Name_To_Name_HTable.Reset (Proj.External_References);
Prj.Ext.Free (Proj.External);
Free (Proj.Project_Path);
Unchecked_Free (Proj);
end if;

15
gcc/ada/prj-tree.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2011, 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- --
@ -32,6 +32,7 @@ with Table;
with Prj.Attr; use Prj.Attr;
with Prj.Env;
with Prj.Ext;
package Prj.Tree is
@ -1453,21 +1454,11 @@ package Prj.Tree is
end Tree_Private_Part;
package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Name_Id,
No_Element => No_Name,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- General type for htables associating name_id to name_id. This is in
-- particular used to store the values of external references.
type Project_Node_Tree_Data is record
Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance;
Projects_HT : Tree_Private_Part.Projects_Htable.Instance;
External_References : Name_To_Name_HTable.Instance;
External : Prj.Ext.External_References;
-- External references are stored in this hash table (and manipulated
-- through subprograms in prj-ext.ads). External references are
-- project-tree specific so that one can load the same tree twice but

15
gcc/ada/s-taprop-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -954,8 +954,13 @@ package body System.Task_Primitives.Operations is
-- Set processor affinity
if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
-- Ada 2012 pragma CPU uses CPU numbers starting from 1, while
-- on VxWorks the first CPU is identified by a 0, so we need to
-- adjust.
Result :=
taskCpuAffinitySet (T.Common.LL.Thread, int (T.Common.Base_CPU));
taskCpuAffinitySet
(T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
elsif T.Common.Task_Info /= Unspecified_Task_Info then
Result :=
@ -1412,10 +1417,14 @@ package body System.Task_Primitives.Operations is
if Environment_Task.Common.Base_CPU /=
System.Multiprocessors.Not_A_Specific_CPU
then
-- Ada 2012 pragma CPU uses CPU numbers starting from 1, while
-- on VxWorks the first CPU is identified by a 0, so we need to
-- adjust.
Result :=
taskCpuAffinitySet
(Environment_Task.Common.LL.Thread,
int (Environment_Task.Common.Base_CPU));
int (Environment_Task.Common.Base_CPU) - 1);
pragma Assert (Result /= -1);
end if;
end Initialize;