+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
if OK then
Prj.Ext.Add
- (Project_Node_Tree,
+ (Project_Node_Tree.External,
External_Name =>
Ext_Asgn (Start .. Equal_Pos - 1),
Value =>
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));
-- --
-- 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- --
end if;
return Prj.Ext.Check
- (Tree => Tree,
+ (Self => Tree.External,
Declaration => Argv (Start .. Finish));
end Is_External_Assignment;
(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,
(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,
-- --
-- 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- --
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);
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+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;
-----------
-----------
function Check
- (Tree : Prj.Tree.Project_Node_Tree_Ref;
+ (Self : External_References;
Declaration : String) return Boolean
is
begin
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 =>
-- 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;
--------------
--------------
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
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;
-- --
-- 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- --
-- 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
-- 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;
(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,
(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,
(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 := "";
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);
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 =>
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 := "";
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
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
-- --
-- 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- --
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;
----------
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;
-- --
-- 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- --
with Prj.Attr; use Prj.Attr;
with Prj.Env;
+with Prj.Ext;
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
-- --
-- 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- --
-- 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 :=
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;
projects / gcc.git / commitdiff