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

2009-07-13 Emmanuel Briot <briot@adacore.com>

Browse Source 
* prj-proc.adb, prj-part.adb, prj-part.ads, prj-strt.adb,
	prj-strt.ads, prj.adb, prj.ads, prj-makr.adb, prj-makr.ads,
	prj-dect.adb, prj-dect.ads, prj-nmsc.adb, prj-pars.adb, errutil.adb,
	errutil.ads, prj-conf.adb, gnatname.adb, prj-err.adb, prj-err.ads
	(Prj.Nmsc.Report_Error): Removed, no longer needed.
	Always use Prj.Err.Report_Message.

From-SVN: r149572
This commit is contained in:
Emmanuel Briot 2009-07-13 12:04:11 +00:00 committed by Arnaud Charlet
parent 442c05811e
commit e2d9085b0f
20 changed files with 722 additions and 766 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2009-07-13 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-part.adb, prj-part.ads, prj-strt.adb,
prj-strt.ads, prj.adb, prj.ads, prj-makr.adb, prj-makr.ads,
prj-dect.adb, prj-dect.ads, prj-nmsc.adb, prj-pars.adb, errutil.adb,
errutil.ads, prj-conf.adb, gnatname.adb, prj-err.adb, prj-err.ads
(Prj.Nmsc.Report_Error): Removed, no longer needed.
Always use Prj.Err.Report_Message.
2009-07-13 Robert Dewar <dewar@adacore.com>
* prj.adb, sem_ch4.adb, sem_res.adb, prj-nmsc.adb: Minor reformatting

2
gcc/ada/errutil.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1991-2009, 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- --

2
gcc/ada/errutil.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2009, 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- --

3
gcc/ada/gnatname.adb
View File

@ -620,7 +620,8 @@ begin
(File_Path => File_Path.all,
Project_File => Create_Project,
Preproc_Switches => Prep_Switches,
Very_Verbose => Very_Verbose);
Very_Verbose => Very_Verbose,
Flags => Gnatmake_Flags);
end;
-- Process each section successively

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

@ -846,7 +846,8 @@ package body Prj.Conf is
Always_Errout_Finalize => False,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => True);
Is_Config_File => True,
Flags => Flags);
else
-- Maybe the user will want to create his own configuration file
Config_Project_Node := Empty_Node;
@ -1004,7 +1005,8 @@ package body Prj.Conf is
Always_Errout_Finalize => False,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => False);
Is_Config_File => False,
Flags => Flags);
if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node;

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

@ -54,7 +54,8 @@ package body Prj.Dect is
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access);
Packages_To_Check : String_List_Access;
Flags : Processing_Flags);
-- Parse an attribute declaration
procedure Parse_Case_Construction
@ -64,7 +65,8 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse a case construction
procedure Parse_Declarative_Items
@ -75,7 +77,8 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse declarative items. Depending on In_Zone, some declarative
-- items may be forbidden.
-- Is_Config_File should be set to True if the project represents a config
@ -86,7 +89,8 @@ package body Prj.Dect is
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse a package declaration.
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
@ -94,14 +98,16 @@ package body Prj.Dect is
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id);
Current_Project : Project_Node_Id;
Flags : Processing_Flags);
-- type <name> is ( <literal_string> { , <literal_string> } ) ;
procedure Parse_Variable_Declaration
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Parse a variable assignment
-- <variable_Name> := <expression>; OR
-- <variable_Name> : <string_type_Name> := <string_expression>;
@ -116,7 +122,8 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Extends : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
First_Declarative_Item : Project_Node_Id := Empty_Node;
@ -135,7 +142,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Empty_Node,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Declarations, In_Tree, To => First_Declarative_Item);
end Parse;
@ -150,7 +158,8 @@ package body Prj.Dect is
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access)
Packages_To_Check : String_List_Access;
Flags : Processing_Flags)
is
Current_Attribute : Attribute_Node_Id := First_Attribute;
Full_Associative_Array : Boolean := False;
@ -224,7 +233,7 @@ package body Prj.Dect is
if not Ignore then
Error_Msg_Name_1 := Token_Name;
Error_Msg ("undefined attribute %%", Token_Ptr);
Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
end if;
end if;
@ -234,7 +243,7 @@ package body Prj.Dect is
if Is_Read_Only (Current_Attribute) then
Error_Msg_Name_1 := Token_Name;
Error_Msg
("read-only attribute %% cannot be given a value",
(Flags, "read-only attribute %% cannot be given a value",
Token_Ptr);
end if;
@ -283,7 +292,8 @@ package body Prj.Dect is
if Current_Attribute /= Empty_Attribute
and then Attribute_Kind_Of (Current_Attribute) = Single
then
Error_Msg ("the attribute """ &
Error_Msg (Flags,
"the attribute """ &
Get_Name_String
(Attribute_Name_Of (Current_Attribute)) &
""" cannot be an associative array",
@ -335,7 +345,8 @@ package body Prj.Dect is
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
Error_Msg
(Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Attribute, In_Tree, To => Index);
@ -346,7 +357,7 @@ package body Prj.Dect is
end if;
when others =>
Error_Msg ("index not allowed here", Token_Ptr);
Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
if Token = Tok_Integer_Literal then
@ -428,7 +439,7 @@ package body Prj.Dect is
(Current_Project, In_Tree, Token_Name);
if No (The_Project) then
Error_Msg ("unknown project", Location);
Error_Msg (Flags, "unknown project", Location);
Scan (In_Tree); -- past the project name
else
@ -458,7 +469,7 @@ package body Prj.Dect is
then
The_Project := Empty_Node;
Error_Msg
("not the same package as " &
(Flags, "not the same package as " &
Get_Name_String
(Name_Of (Current_Package, In_Tree)),
Token_Ptr);
@ -486,8 +497,9 @@ package body Prj.Dect is
Error_Msg_Name_2 := Project_Name;
Error_Msg_Name_1 := Token_Name;
Error_Msg
("package % not declared in project %",
Token_Ptr);
(Flags,
"package % not declared in project %",
Token_Ptr);
end if;
Scan (In_Tree); -- past the package name
@ -519,7 +531,8 @@ package body Prj.Dect is
if Token_Name /= Attribute_Name then
The_Project := Empty_Node;
Error_Msg_Name_1 := Attribute_Name;
Error_Msg ("invalid name, should be %", Token_Ptr);
Error_Msg
(Flags, "invalid name, should be %", Token_Ptr);
end if;
Scan (In_Tree); -- past the attribute name
@ -561,6 +574,7 @@ package body Prj.Dect is
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);
@ -581,7 +595,7 @@ package body Prj.Dect is
else
Error_Msg
("wrong expression kind for attribute """ &
(Flags, "wrong expression kind for attribute """ &
Get_Name_String
(Attribute_Name_Of (Current_Attribute)) &
"""",
@ -615,7 +629,8 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_Item : Project_Node_Id := Empty_Node;
Next_Item : Project_Node_Id := Empty_Node;
@ -653,6 +668,7 @@ package body Prj.Dect is
Parse_Variable_Reference
(In_Tree => In_Tree,
Variable => Case_Variable,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Case_Variable_Reference_Of
@ -668,7 +684,8 @@ package body Prj.Dect is
String_Type := String_Type_Of (Case_Variable, In_Tree);
if No (String_Type) then
Error_Msg ("variable """ &
Error_Msg (Flags,
"variable """ &
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
""" is not typed",
Variable_Location);
@ -739,7 +756,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
-- "when others =>" must be the last branch, so save the
-- Case_Item and exit
@ -751,7 +769,8 @@ package body Prj.Dect is
else
Parse_Choice_List
(In_Tree => In_Tree,
First_Choice => First_Choice);
First_Choice => First_Choice,
Flags => Flags);
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
@ -766,7 +785,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Current_Item, In_Tree, To => First_Declarative_Item);
@ -776,7 +796,8 @@ package body Prj.Dect is
End_Case_Construction
(Check_All_Labels => not When_Others and not Quiet_Output,
Case_Location => Location_Of (Case_Construction, In_Tree));
Case_Location => Location_Of (Case_Construction, In_Tree),
Flags => Flags);
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;
@ -812,7 +833,8 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_Declarative_Item : Project_Node_Id := Empty_Node;
Next_Declarative_Item : Project_Node_Id := Empty_Node;
@ -861,7 +883,8 @@ package body Prj.Dect is
if No (The_Variable) then
Error_Msg
("a variable cannot be declared " &
(Flags,
"a variable cannot be declared " &
"for the first time here",
Token_Ptr);
end if;
@ -872,7 +895,8 @@ package body Prj.Dect is
(In_Tree,
Current_Declaration,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
@ -885,7 +909,8 @@ package body Prj.Dect is
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check);
Packages_To_Check => Packages_To_Check,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
@ -899,7 +924,8 @@ package body Prj.Dect is
-- Package declaration
if In_Zone /= In_Project then
Error_Msg ("a package cannot be declared here", Token_Ptr);
Error_Msg
(Flags, "a package cannot be declared here", Token_Ptr);
end if;
Parse_Package_Declaration
@ -907,7 +933,8 @@ package body Prj.Dect is
Package_Declaration => Current_Declaration,
Current_Project => Current_Project,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
@ -916,14 +943,16 @@ package body Prj.Dect is
-- Type String Declaration
if In_Zone /= In_Project then
Error_Msg ("a string type cannot be declared here",
Error_Msg (Flags,
"a string type cannot be declared here",
Token_Ptr);
end if;
Parse_String_Type_Declaration
(In_Tree => In_Tree,
String_Type => Current_Declaration,
Current_Project => Current_Project);
Current_Project => Current_Project,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
@ -939,7 +968,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
@ -993,7 +1023,8 @@ package body Prj.Dect is
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
First_Attribute : Attribute_Node_Id := Empty_Attribute;
Current_Package : Package_Node_Id := Empty_Package;
@ -1044,7 +1075,8 @@ package body Prj.Dect is
-- misspelling has been found.
if Verbose_Mode or else Index /= 0 then
Error_Msg ("?""" &
Error_Msg (Flags,
"?""" &
Get_Name_String
(Name_Of (Package_Declaration, In_Tree)) &
""" is not a known package name",
@ -1053,7 +1085,8 @@ package body Prj.Dect is
if Index /= 0 then
Error_Msg -- CODEFIX
("\?possible misspelling of """ &
(Flags,
"\?possible misspelling of """ &
List (Index).all & """", Token_Ptr);
end if;
end;
@ -1095,7 +1128,8 @@ package body Prj.Dect is
if Present (Current) then
Error_Msg
("package """ &
(Flags,
"package """ &
Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
""" is declared twice in the same project",
Token_Ptr);
@ -1119,7 +1153,8 @@ package body Prj.Dect is
if Token = Tok_Renames then
if Is_Config_File then
Error_Msg
("no package renames in configuration projects", Token_Ptr);
(Flags,
"no package renames in configuration projects", Token_Ptr);
end if;
-- Scan past "renames"
@ -1164,7 +1199,8 @@ package body Prj.Dect is
else
Error_Msg_Name_1 := Project_Name;
Error_Msg
("% is not an imported or extended project", Token_Ptr);
(Flags,
"% is not an imported or extended project", Token_Ptr);
end if;
else
Set_Project_Of_Renamed_Package_Of
@ -1181,7 +1217,7 @@ package body Prj.Dect is
if Token = Tok_Identifier then
if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
Error_Msg ("not the same package name", Token_Ptr);
Error_Msg (Flags, "not the same package name", Token_Ptr);
elsif
Present (Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree))
@ -1203,7 +1239,7 @@ package body Prj.Dect is
if No (Current) then
Error_Msg
("""" &
(Flags, """" &
Get_Name_String (Token_Name) &
""" is not a package declared by the project",
Token_Ptr);
@ -1233,7 +1269,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Package_Declaration,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Package_Declaration, In_Tree, To => First_Declarative_Item);
@ -1256,7 +1293,7 @@ package body Prj.Dect is
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
then
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
Error_Msg ("expected %%", Token_Ptr);
Error_Msg (Flags, "expected %%", Token_Ptr);
end if;
if Token /= Tok_Semicolon then
@ -1270,7 +1307,7 @@ package body Prj.Dect is
Remove_Next_End_Node;
else
Error_Msg ("expected IS or RENAMES", Token_Ptr);
Error_Msg (Flags, "expected IS or RENAMES", Token_Ptr);
end if;
end Parse_Package_Declaration;
@ -1282,7 +1319,8 @@ package body Prj.Dect is
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id)
Current_Project : Project_Node_Id;
Flags : Processing_Flags)
is
Current : Project_Node_Id := Empty_Node;
First_String : Project_Node_Id := Empty_Node;
@ -1312,7 +1350,8 @@ package body Prj.Dect is
end loop;
if Present (Current) then
Error_Msg ("duplicate string type name """ &
Error_Msg (Flags,
"duplicate string type name """ &
Get_Name_String (Token_Name) &
"""",
Token_Ptr);
@ -1325,7 +1364,8 @@ package body Prj.Dect is
end loop;
if Present (Current) then
Error_Msg ("""" &
Error_Msg (Flags,
"""" &
Get_Name_String (Token_Name) &
""" is already a variable name", Token_Ptr);
else
@ -1355,7 +1395,7 @@ package body Prj.Dect is
end if;
Parse_String_Type_List
(In_Tree => In_Tree, First_String => First_String);
(In_Tree => In_Tree, First_String => First_String, Flags => Flags);
Set_First_Literal_String (String_Type, In_Tree, To => First_String);
Expect (Tok_Right_Paren, "`)`");
@ -1374,7 +1414,8 @@ package body Prj.Dect is
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Expression_Location : Source_Ptr;
String_Type_Name : Name_Id := No_Name;
@ -1448,7 +1489,8 @@ package body Prj.Dect is
if The_Project_Name_And_Node =
Tree_Private_Part.No_Project_Name_And_Node
then
Error_Msg ("unknown project """ &
Error_Msg (Flags,
"unknown project """ &
Get_Name_String
(Project_String_Type_Name) &
"""",
@ -1491,7 +1533,8 @@ package body Prj.Dect is
end if;
if No (Current) then
Error_Msg ("unknown string type """ &
Error_Msg (Flags,
"unknown string type """ &
Get_Name_String (String_Type_Name) &
"""",
Type_Location);
@ -1521,6 +1564,7 @@ package body Prj.Dect is
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => False);
@ -1533,7 +1577,8 @@ package body Prj.Dect is
and then Expression_Kind_Of (Expression, In_Tree) = List
then
Error_Msg
("expression must be a single string", Expression_Location);
(Flags,
"expression must be a single string", Expression_Location);
end if;
Set_Expression_Kind_Of
@ -1587,7 +1632,8 @@ package body Prj.Dect is
if Expression_Kind_Of (The_Variable, In_Tree) /=
Expression_Kind_Of (Variable, In_Tree)
then
Error_Msg ("wrong expression kind for variable """ &
Error_Msg (Flags,
"wrong expression kind for variable """ &
Get_Name_String
(Name_Of (The_Variable, In_Tree)) &
"""",

5
gcc/ada/prj-dect.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, 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- --
@ -35,7 +35,8 @@ private package Prj.Dect is
Current_Project : Prj.Tree.Project_Node_Id;
Extends : Prj.Tree.Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse project declarative items
--
-- In_Tree is the project node tree

51
gcc/ada/prj-err.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2009, 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- --
@ -68,4 +68,53 @@ package body Prj.Err is
end if;
end Post_Scan;
---------------
-- Error_Msg --
---------------
procedure Error_Msg
(Flags : Processing_Flags;
Msg : String;
Location : Source_Ptr := No_Location;
Project : Project_Id := null)
is
Real_Location : Source_Ptr := Location;
begin
-- Display the error message in the traces so that it appears in the
-- correct location in the traces (otherwise error messages are only
-- displayed at the end and it is difficult to see when they were
-- triggered)
if Current_Verbosity = High then
Write_Line ("ERROR: " & Msg);
end if;
-- If location of error is unknown, use the location of the project
if Real_Location = No_Location
and then Project /= null
then
Real_Location := Project.Location;
end if;
if Real_Location = No_Location then
-- If still null, we are parsing a project that was created in-memory
-- so we shouldn't report errors for projects that the user has no
-- access to in any case.
return;
end if;
-- Report the error through Errutil, so that duplicate errors are
-- properly removed, messages are sorted, and correctly interpreted,...
Errutil.Error_Msg (Msg, Real_Location);
-- Let the application know there was an error
if Flags.Report_Error /= null then
Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?');
end if;
end Error_Msg;
end Prj.Err;

49
gcc/ada/prj-err.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2009, 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- --
@ -28,6 +28,14 @@
-- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global
-- variables as Errout, located in package Err_Vars. Like Errout, it also uses
-- the common variables and routines in package Erroutc.
--
-- Parameters are set through Err_Vars.Error_Msg_File_* or
-- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages
-- ("{{" for files, "%%" for names).
--
-- However, in this package you can configure the error messages to be sent
-- to your own callback by setting Report_Error in the flags. This ensures
-- that applications can control where error messages are displayed.
with Scng;
with Errutil;
@ -59,29 +67,22 @@ package Prj.Err is
-- Finalize processing of error messages for one file and output message
-- indicating the number of detected errors.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr)
renames Errutil.Error_Msg;
-- Output a message at specified location
procedure Error_Msg_S (Msg : String) renames Errutil.Error_Msg_S;
-- Output a message at current scan pointer location
procedure Error_Msg_SC (Msg : String) renames Errutil.Error_Msg_SC;
-- Output a message at the start of the current token, unless we are at
-- the end of file, in which case we always output the message after the
-- last real token in the file.
procedure Error_Msg_SP (Msg : String) renames Errutil.Error_Msg_SP;
-- Output a message at the start of the previous token
procedure Error_Msg
(Flags : Processing_Flags;
Msg : String;
Location : Source_Ptr := No_Location;
Project : Project_Id := null);
-- Output an error message, either through Flags.Error_Report or through
-- Errutil. The location defaults to the project's location ("project" in
-- the source code).
-- If Msg starts with "?", this is a warning, and Warning: is added at the
-- beginning. If Msg starts with "<", see comment for
-- Err_Vars.Error_Msg_Warn
-------------
-- Scanner --
-------------
package Style renames Errutil.Style;
-- Instantiation of the generic style package, needed for the instantiation
-- of the generic scanner below.
procedure Obsolescent_Check (S : Source_Ptr);
-- Dummy null procedure for Scng instantiation
@ -90,12 +91,12 @@ package Prj.Err is
package Scanner is new Scng
(Post_Scan => Post_Scan,
Error_Msg => Error_Msg,
Error_Msg_S => Error_Msg_S,
Error_Msg_SC => Error_Msg_SC,
Error_Msg_SP => Error_Msg_SP,
Error_Msg => Errutil.Error_Msg,
Error_Msg_S => Errutil.Error_Msg_S,
Error_Msg_SC => Errutil.Error_Msg_SC,
Error_Msg_SP => Errutil.Error_Msg_SP,
Obsolescent_Check => Obsolescent_Check,
Style => Style);
Style => Errutil.Style);
-- Instantiation of the generic scanner
end Prj.Err;

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

@ -766,7 +766,8 @@ package body Prj.Makr is
(File_Path : String;
Project_File : Boolean;
Preproc_Switches : Argument_List;
Very_Verbose : Boolean)
Very_Verbose : Boolean;
Flags : Processing_Flags)
is
begin
Makr.Very_Verbose := Initialize.Very_Verbose;
@ -846,6 +847,7 @@ package body Prj.Makr is
Always_Errout_Finalize => False,
Store_Comments => True,
Is_Config_File => False,
Flags => Flags,
Current_Directory => Get_Current_Dir,
Packages_To_Check => Packages_To_Check_By_Gnatname);

5
gcc/ada/prj-makr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, 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- --
@ -36,7 +36,8 @@ package Prj.Makr is
(File_Path : String;
Project_File : Boolean;
Preproc_Switches : Argument_List;
Very_Verbose : Boolean);
Very_Verbose : Boolean;
Flags : Processing_Flags);
-- Start the creation of a configuration pragmas file or the creation or
-- modification of a project file, for gnatname.
--

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

File diff suppressed because it is too large Load Diff

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

@ -68,6 +68,7 @@ package body Prj.Pars is
Always_Errout_Finalize => False,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Dir,
Flags => Flags,
Is_Config_File => False);
-- If there were no error, process the tree

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

@ -165,7 +165,8 @@ package body Prj.Part is
Packages_To_Check : String_List_Access;
Depth : Natural;
Current_Dir : String;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse a project file. This is a recursive procedure: it calls itself for
-- imported and extended projects. When From_Extended is not None, if the
-- project has already been parsed and is an extended project A, return the
@ -179,7 +180,8 @@ package body Prj.Part is
procedure Pre_Parse_Context_Clause
(In_Tree : Project_Node_Tree_Ref;
Context_Clause : out With_Id;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse the context clause of a project. Store the paths and locations of
-- the imported projects in table Withs. Does nothing if there is no
-- context clause (if the current token is not "with" or "limited" followed
@ -198,7 +200,8 @@ package body Prj.Part is
Packages_To_Check : String_List_Access;
Depth : Natural;
Current_Dir : String;
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse the imported projects that have been stored in table Withs, if
-- any. From_Extended is used for the call to Parse_Single_Project below.
-- When In_Limited is True, the importing path includes at least one
@ -431,7 +434,8 @@ package body Prj.Part is
Packages_To_Check : String_List_Access := All_Packages;
Store_Comments : Boolean := False;
Current_Directory : String := "";
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Dummy : Boolean;
pragma Warnings (Off, Dummy);
@ -490,7 +494,8 @@ package body Prj.Part is
Packages_To_Check => Packages_To_Check,
Depth => 0,
Current_Dir => Current_Directory,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
-- If Project is an extending-all project, create the eventual
-- virtual extending projects and check that there are no illegally
@ -600,7 +605,8 @@ package body Prj.Part is
procedure Pre_Parse_Context_Clause
(In_Tree : Project_Node_Tree_Ref;
Context_Clause : out With_Id;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_With_Clause : With_Id := No_With;
Limited_With : Boolean := False;
@ -623,7 +629,8 @@ package body Prj.Part is
if Is_Config_File then
Error_Msg
("configuration project cannot import " &
(Flags,
"configuration project cannot import " &
"other configuration projects",
Token_Ptr);
end if;
@ -680,7 +687,7 @@ package body Prj.Part is
Set_Is_Not_Last_In_List (Current_With_Node, In_Tree);
else
Error_Msg ("expected comma or semi colon", Token_Ptr);
Error_Msg (Flags, "expected comma or semi colon", Token_Ptr);
exit Comma_Loop;
end if;
@ -706,7 +713,8 @@ package body Prj.Part is
Packages_To_Check : String_List_Access;
Depth : Natural;
Current_Dir : String;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_With_Clause : With_Id := Context_Clause;
@ -763,7 +771,7 @@ package body Prj.Part is
Error_Msg_File_1 := File_Name_Type (Current_With.Path);
Error_Msg
("unknown project file: {", Current_With.Location);
(Flags, "unknown project file: {", Current_With.Location);
-- If this is not imported by the main project file, display
-- the import path.
@ -774,7 +782,7 @@ package body Prj.Part is
File_Name_Type
(Project_Stack.Table (Index).Path_Name);
Error_Msg
("\imported by {", Current_With.Location);
(Flags, "\imported by {", Current_With.Location);
end loop;
end if;
@ -846,7 +854,8 @@ package body Prj.Part is
Packages_To_Check => Packages_To_Check,
Depth => Depth,
Current_Dir => Current_Dir,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
else
Extends_All := Is_Extending_All (Withed_Project, In_Tree);
@ -908,7 +917,8 @@ package body Prj.Part is
Packages_To_Check : String_List_Access;
Depth : Natural;
Current_Dir : String;
Is_Config_File : Boolean)
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Normed_Path_Name : Path_Name_Type;
Canonical_Path_Name : Path_Name_Type;
@ -971,9 +981,9 @@ package body Prj.Part is
if Canonical_Path_Name =
Project_Stack.Table (Index).Canonical_Path_Name
then
Error_Msg ("circular dependency detected", Token_Ptr);
Error_Msg (Flags, "circular dependency detected", Token_Ptr);
Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
Error_Msg ("\ %% is imported by", Token_Ptr);
Error_Msg (Flags, "\ %% is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 :=
@ -983,10 +993,10 @@ package body Prj.Part is
Canonical_Path_Name
then
Error_Msg
("\ %% which itself is imported by", Token_Ptr);
(Flags, "\ %% which itself is imported by", Token_Ptr);
else
Error_Msg ("\ %%", Token_Ptr);
Error_Msg (Flags, "\ %%", Token_Ptr);
exit;
end if;
end loop;
@ -1015,12 +1025,14 @@ package body Prj.Part is
if A_Project_Name_And_Node.Extended then
if A_Project_Name_And_Node.Proj_Qualifier /= Dry then
Error_Msg
("cannot extend the same project file several times",
(Flags,
"cannot extend the same project file several times",
Token_Ptr);
end if;
else
Error_Msg
("cannot extend an already imported project file",
(Flags,
"cannot extend an already imported project file",
Token_Ptr);
end if;
@ -1060,7 +1072,8 @@ package body Prj.Part is
end;
else
Error_Msg
("cannot import an already extended project file",
(Flags,
"cannot import an already extended project file",
Token_Ptr);
end if;
end if;
@ -1099,7 +1112,8 @@ package body Prj.Part is
-- following Ada identifier's syntax).
Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name);
Error_Msg ("?{ is not a valid path name for a project file",
Error_Msg (Flags,
"?{ is not a valid path name for a project file",
Token_Ptr);
end if;
@ -1118,7 +1132,8 @@ package body Prj.Part is
Pre_Parse_Context_Clause
(In_Tree => In_Tree,
Is_Config_File => Is_Config_File,
Context_Clause => First_With);
Context_Clause => First_With,
Flags => Flags);
Project := Default_Project_Node
(Of_Kind => N_Project, In_Tree => In_Tree);
@ -1157,9 +1172,11 @@ package body Prj.Part is
when Snames.Name_Configuration =>
if not Is_Config_File then
Error_Msg ("configuration projects cannot belong to a user" &
" project tree",
Token_Ptr);
Error_Msg
(Flags,
"configuration projects cannot belong to a user" &
" project tree",
Token_Ptr);
end if;
Proj_Qualifier := Configuration;
@ -1183,7 +1200,8 @@ package body Prj.Part is
if Is_Config_File
and then Proj_Qualifier /= Configuration
then
Error_Msg ("a configuration project cannot be qualified except " &
Error_Msg (Flags,
"a configuration project cannot be qualified except " &
"as configuration project",
Qualifier_Location);
end if;
@ -1242,7 +1260,8 @@ package body Prj.Part is
if Is_Config_File then
Error_Msg
("extending configuration project not allowed", Token_Ptr);
(Flags,
"extending configuration project not allowed", Token_Ptr);
end if;
-- Make sure that gnatmake will use mapping files
@ -1306,9 +1325,11 @@ package body Prj.Part is
Extension := new String'(Project_File_Extension);
end if;
Error_Msg ("?file name does not match project name, " &
"should be `%%" & Extension.all & "`",
Token_Ptr);
Error_Msg
(Flags,
"?file name does not match project name, should be `%%"
& Extension.all & "`",
Token_Ptr);
end if;
end;
@ -1339,7 +1360,8 @@ package body Prj.Part is
Packages_To_Check => Packages_To_Check,
Depth => Depth + 1,
Current_Dir => Current_Dir,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
end;
@ -1368,12 +1390,12 @@ package body Prj.Part is
Duplicated := True;
Error_Msg_Name_1 := Project_Name;
Error_Msg
("duplicate project name %%",
(Flags, "duplicate project name %%",
Location_Of (Project, In_Tree));
Error_Msg_Name_1 :=
Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree));
Error_Msg
("\already in %%", Location_Of (Project, In_Tree));
(Flags, "\already in %%", Location_Of (Project, In_Tree));
end if;
end;
end if;
@ -1406,7 +1428,7 @@ package body Prj.Part is
Error_Msg_Name_1 := Token_Name;
Error_Msg ("unknown project file: %%", Token_Ptr);
Error_Msg (Flags, "unknown project file: %%", Token_Ptr);
-- If we are not in the main project file, display the
-- import path.
@ -1415,13 +1437,13 @@ package body Prj.Part is
Error_Msg_Name_1 :=
Name_Id
(Project_Stack.Table (Project_Stack.Last).Path_Name);
Error_Msg ("\extended by %%", Token_Ptr);
Error_Msg (Flags, "\extended by %%", Token_Ptr);
for Index in reverse 1 .. Project_Stack.Last - 1 loop
Error_Msg_Name_1 :=
Name_Id
(Project_Stack.Table (Index).Path_Name);
Error_Msg ("\imported by %%", Token_Ptr);
Error_Msg (Flags, "\imported by %%", Token_Ptr);
end loop;
end if;
@ -1445,7 +1467,8 @@ package body Prj.Part is
Packages_To_Check => Packages_To_Check,
Depth => Depth + 1,
Current_Dir => Current_Dir,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
end;
if Present (Extended_Project) then
@ -1466,7 +1489,7 @@ package body Prj.Part is
Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
then
Error_Msg
("an abstract project can only extend " &
(Flags, "an abstract project can only extend " &
"another abstract project",
Qualifier_Location);
end if;
@ -1494,7 +1517,7 @@ package body Prj.Part is
if Is_Extending_All (With_Clause, In_Tree) then
Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
Error_Msg ("cannot import extending-all project %%",
Error_Msg (Flags, "cannot import extending-all project %%",
Token_Ptr);
exit With_Clause_Loop;
end if;
@ -1559,7 +1582,8 @@ package body Prj.Part is
Error_Msg_Name_1 := Name_Of_Project;
Error_Msg_Name_2 := Parent_Name;
Error_Msg ("project %% does not import or extend project %%",
Error_Msg (Flags,
"project %% does not import or extend project %%",
Location_Of (Project, In_Tree));
end if;
end;
@ -1582,7 +1606,8 @@ package body Prj.Part is
Current_Project => Project,
Extends => Extended_Project,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
if Present (Extended_Project)
@ -1641,7 +1666,7 @@ package body Prj.Part is
then
-- Invalid name: report an error
Error_Msg ("expected """ &
Error_Msg (Flags, "expected """ &
Get_Name_String (Name_Of (Project, In_Tree)) & """",
Token_Ptr);
end if;
@ -1658,7 +1683,7 @@ package body Prj.Part is
if Token /= Tok_EOF then
Error_Msg
("unexpected text following end of project", Token_Ptr);
(Flags, "unexpected text following end of project", Token_Ptr);
end if;
end if;
@ -1704,7 +1729,8 @@ package body Prj.Part is
Packages_To_Check => Packages_To_Check,
Depth => Depth + 1,
Current_Dir => Current_Dir,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
end;

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

@ -37,7 +37,8 @@ package Prj.Part is
Packages_To_Check : String_List_Access := All_Packages;
Store_Comments : Boolean := False;
Current_Directory : String := "";
Is_Config_File : Boolean);
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse project file and all its imported project files and create a tree.
-- Return the node for the project (or Empty_Node if parsing failed). If
-- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,

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

@ -101,7 +101,7 @@ package body Prj.Proc is
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
@ -124,7 +124,7 @@ package body Prj.Proc is
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
@ -488,7 +488,7 @@ package body Prj.Proc is
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
@ -593,7 +593,7 @@ package body Prj.Proc is
Value := Expression
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
@ -643,7 +643,7 @@ package body Prj.Proc is
Expression
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
@ -1028,7 +1028,7 @@ package body Prj.Proc is
Def_Var := Expression
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
@ -1046,17 +1046,11 @@ package body Prj.Proc is
if Value = No_Name then
if not Quiet_Output then
if Report_Error = null then
Error_Msg
("?undefined external reference",
Location_Of
(The_Current_Term, From_Project_Node_Tree));
else
Report_Error
("warning: """ & Get_Name_String (Name) &
""" is an undefined external reference",
Project, In_Tree);
end if;
Error_Msg
(Flags, "?undefined external reference",
Location_Of
(The_Current_Term, From_Project_Node_Tree),
Project);
end if;
Value := Empty_String;
@ -1255,7 +1249,7 @@ package body Prj.Proc is
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
@ -1391,7 +1385,7 @@ package body Prj.Proc is
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => New_Pkg,
@ -1580,16 +1574,11 @@ package body Prj.Proc is
end loop;
if Orig_Array = No_Array then
if Report_Error = null then
Error_Msg
("associative array value not found",
Location_Of
(Current_Item, From_Project_Node_Tree));
else
Report_Error
("associative array value not found",
Project, In_Tree);
end if;
Error_Msg
(Flags,
"associative array value not found",
Location_Of (Current_Item, From_Project_Node_Tree),
Project);
else
Orig_Element :=
@ -1692,7 +1681,7 @@ package body Prj.Proc is
Expression
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
@ -1729,18 +1718,12 @@ package body Prj.Proc is
if New_Value.Value = Empty_String then
Error_Msg_Name_1 :=
Name_Of (Current_Item, From_Project_Node_Tree);
if Report_Error = null then
Error_Msg
("no value defined for %%",
Location_Of
(Current_Item, From_Project_Node_Tree));
else
Report_Error
("no value defined for " &
Get_Name_String (Error_Msg_Name_1),
Project, In_Tree);
end if;
Error_Msg
(Flags,
"no value defined for %%",
Location_Of
(Current_Item, From_Project_Node_Tree),
Project);
else
declare
@ -1774,24 +1757,12 @@ package body Prj.Proc is
Error_Msg_Name_2 :=
Name_Of
(Current_Item, From_Project_Node_Tree);
if Report_Error = null then
Error_Msg
("value %% is illegal " &
"for typed string %%",
Location_Of
(Current_Item,
From_Project_Node_Tree));
else
Report_Error
("value """ &
Get_Name_String (Error_Msg_Name_1) &
""" is illegal for typed string """ &
Get_Name_String (Error_Msg_Name_2) &
"""",
Project, In_Tree);
end if;
Error_Msg
(Flags,
"value %% is illegal for typed string %%",
Location_Of
(Current_Item, From_Project_Node_Tree),
Project);
end if;
end;
end if;
@ -2198,7 +2169,7 @@ package body Prj.Proc is
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
Report_Error => Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
@ -2331,44 +2302,23 @@ package body Prj.Proc is
then
if Extending2.Virtual then
Error_Msg_Name_1 := Prj.Project.Display_Name;
if Flags.Report_Error = null then
Error_Msg
("project %% cannot be extended by a virtual" &
" project with the same object directory",
Prj.Project.Location);
else
Flags.Report_Error
("project """ &
Get_Name_String (Error_Msg_Name_1) &
""" cannot be extended by a virtual " &
"project with the same object directory",
Project, In_Tree);
end if;
Error_Msg
(Flags,
"project %% cannot be extended by a virtual" &
" project with the same object directory",
Prj.Project.Location, Project);
else
Error_Msg_Name_1 := Extending2.Display_Name;
Error_Msg_Name_2 := Prj.Project.Display_Name;
if Flags.Report_Error = null then
Error_Msg
("project %% cannot extend project %%",
Extending2.Location);
Error_Msg
("\they share the same object directory",
Extending2.Location);
else
Flags.Report_Error
("project """ &
Get_Name_String (Error_Msg_Name_1) &
""" cannot extend project """ &
Get_Name_String (Error_Msg_Name_2) & """",
Project, In_Tree);
Flags.Report_Error
("they share the same object directory",
Project, In_Tree);
end if;
Error_Msg
(Flags,
"project %% cannot extend project %%",
Extending2.Location, Project);
Error_Msg
(Flags,
"\they share the same object directory",
Extending2.Location, Project);
end if;
end if;
@ -2588,7 +2538,7 @@ package body Prj.Proc is
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
Report_Error => Flags.Report_Error,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => No_Package,

98
gcc/ada/prj-strt.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, 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- --
@ -108,7 +108,8 @@ package body Prj.Strt is
(In_Tree : Project_Node_Tree_Ref;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
External_Value : out Project_Node_Id);
External_Value : out Project_Node_Id;
Flags : Processing_Flags);
-- Parse an external reference. Current token is "external"
procedure Attribute_Reference
@ -116,7 +117,8 @@ package body Prj.Strt is
Reference : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Parse an attribute reference. Current token is an apostrophe
procedure Terms
@ -125,7 +127,8 @@ package body Prj.Strt is
Expr_Kind : in out Variable_Kind;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Optional_Index : Boolean);
Optional_Index : Boolean;
Flags : Processing_Flags);
-- Recursive procedure to parse one term or several terms concatenated
-- using "&".
@ -160,7 +163,8 @@ package body Prj.Strt is
Reference : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Current_Attribute : Attribute_Node_Id := First_Attribute;
@ -195,7 +199,7 @@ package body Prj.Strt is
if Current_Attribute = Empty_Attribute then
Error_Msg_Name_1 := Token_Name;
Error_Msg ("unknown attribute %%", Token_Ptr);
Error_Msg (Flags, "unknown attribute %%", Token_Ptr);
Reference := Empty_Node;
-- Scan past the attribute name
@ -273,7 +277,8 @@ package body Prj.Strt is
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr)
Case_Location : Source_Ptr;
Flags : Processing_Flags)
is
Non_Used : Natural := 0;
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
@ -296,19 +301,19 @@ package body Prj.Strt is
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg ("?value %% is not used as label", Case_Location);
Error_Msg (Flags, "?value %% is not used as label", Case_Location);
-- If several are not used, report a warning for each one of them
elsif Non_Used > 1 then
Error_Msg
("?the following values are not used as labels:",
(Flags, "?the following values are not used as labels:",
Case_Location);
for Choice in First_Non_Used .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
Error_Msg ("\?%%", Case_Location);
Error_Msg (Flags, "\?%%", Case_Location);
end if;
end loop;
end if;
@ -347,7 +352,8 @@ package body Prj.Strt is
(In_Tree : Project_Node_Tree_Ref;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
External_Value : out Project_Node_Id)
External_Value : out Project_Node_Id;
Flags : Processing_Flags)
is
Field_Id : Project_Node_Id := Empty_Node;
@ -406,12 +412,14 @@ package body Prj.Strt is
Parse_Expression
(In_Tree => In_Tree,
Expression => Field_Id,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => False);
if Expression_Kind_Of (Field_Id, In_Tree) = List then
Error_Msg ("expression must be a single string", Loc);
Error_Msg
(Flags, "expression must be a single string", Loc);
else
Set_External_Default_Of
(External_Value, In_Tree, To => Field_Id);
@ -425,7 +433,7 @@ package body Prj.Strt is
end if;
when others =>
Error_Msg ("`,` or `)` expected", Token_Ptr);
Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);
end case;
end if;
end External_Reference;
@ -436,7 +444,8 @@ package body Prj.Strt is
procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id)
First_Choice : out Project_Node_Id;
Flags : Processing_Flags)
is
Current_Choice : Project_Node_Id := Empty_Node;
Next_Choice : Project_Node_Id := Empty_Node;
@ -483,7 +492,7 @@ package body Prj.Strt is
-- case construction so report an error.
Error_Msg_Name_1 := Choice_String;
Error_Msg ("duplicate case label %%", Token_Ptr);
Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
else
Choices.Table (Choice).Already_Used := True;
@ -497,7 +506,7 @@ package body Prj.Strt is
if not Found then
Error_Msg_Name_1 := Choice_String;
Error_Msg ("illegal case label %%", Token_Ptr);
Error_Msg (Flags, "illegal case label %%", Token_Ptr);
end if;
-- Scan past the label
@ -535,7 +544,8 @@ package body Prj.Strt is
Expression : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Optional_Index : Boolean)
Optional_Index : Boolean;
Flags : Processing_Flags)
is
First_Term : Project_Node_Id := Empty_Node;
Expression_Kind : Variable_Kind := Undefined;
@ -552,6 +562,7 @@ package body Prj.Strt is
Terms (In_Tree => In_Tree,
Term => First_Term,
Expr_Kind => Expression_Kind,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);
@ -568,7 +579,8 @@ package body Prj.Strt is
procedure Parse_String_Type_List
(In_Tree : Project_Node_Tree_Ref;
First_String : out Project_Node_Id)
First_String : out Project_Node_Id;
Flags : Processing_Flags)
is
Last_String : Project_Node_Id := Empty_Node;
Next_String : Project_Node_Id := Empty_Node;
@ -609,7 +621,7 @@ package body Prj.Strt is
-- This is a repetition, report an error
Error_Msg_Name_1 := String_Value;
Error_Msg ("duplicate value %% in type", Token_Ptr);
Error_Msg (Flags, "duplicate value %% in type", Token_Ptr);
exit;
end if;
@ -650,7 +662,8 @@ package body Prj.Strt is
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Current_Variable : Project_Node_Id := Empty_Node;
@ -723,7 +736,7 @@ package body Prj.Strt is
if First_Attribute = Empty_Attribute then
Error_Msg_Name_1 := Names.Table (1).Name;
Error_Msg ("unknown project %",
Error_Msg (Flags, "unknown project %",
Names.Table (1).Location);
First_Attribute := Attribute_First;
@ -747,7 +760,7 @@ package body Prj.Strt is
if No (The_Package) then
Error_Msg_Name_1 := Names.Table (1).Name;
Error_Msg ("package % not yet defined",
Error_Msg (Flags, "package % not yet defined",
Names.Table (1).Location);
end if;
end if;
@ -844,7 +857,7 @@ package body Prj.Strt is
if No (The_Project) then
Error_Msg_Name_1 := Long_Project;
Error_Msg_Name_2 := Short_Project;
Error_Msg ("unknown projects % or %",
Error_Msg (Flags, "unknown projects % or %",
Names.Table (1).Location);
The_Package := Empty_Node;
First_Attribute := Attribute_First;
@ -869,7 +882,8 @@ package body Prj.Strt is
Error_Msg_Name_1 :=
Names.Table (Names.Last).Name;
Error_Msg_Name_2 := Short_Project;
Error_Msg ("package % not declared in project %",
Error_Msg (Flags,
"package % not declared in project %",
Names.Table (Names.Last).Location);
First_Attribute := Attribute_First;
@ -889,6 +903,7 @@ package body Prj.Strt is
Attribute_Reference
(In_Tree,
Variable,
Flags => Flags,
Current_Project => The_Project,
Current_Package => The_Package,
First_Attribute => First_Attribute);
@ -944,7 +959,7 @@ package body Prj.Strt is
elsif No (The_Package) then
Error_Msg_Name_1 := Names.Table (1).Name;
Error_Msg ("unknown package or project %",
Error_Msg (Flags, "unknown package or project %",
Names.Table (1).Location);
Look_For_Variable := False;
@ -1023,7 +1038,7 @@ package body Prj.Strt is
Error_Msg_Name_1 := Long_Project;
Error_Msg_Name_2 := Short_Project;
Error_Msg
("unknown projects % or %",
(Flags, "unknown projects % or %",
Names.Table (1).Location);
Look_For_Variable := False;
@ -1047,7 +1062,7 @@ package body Prj.Strt is
-- The package does not exist, report an error
Error_Msg_Name_1 := Names.Table (2).Name;
Error_Msg ("unknown package %",
Error_Msg (Flags, "unknown package %",
Names.Table (Names.Last - 1).Location);
Look_For_Variable := False;
@ -1143,7 +1158,7 @@ package body Prj.Strt is
if No (Current_Variable) then
Error_Msg_Name_1 := Variable_Name;
Error_Msg
("unknown variable %", Names.Table (Names.Last).Location);
(Flags, "unknown variable %", Names.Table (Names.Last).Location);
end if;
end if;
@ -1165,7 +1180,8 @@ package body Prj.Strt is
-- but attempt to scan the index.
if Token = Tok_Left_Paren then
Error_Msg ("\variables cannot be associative arrays", Token_Ptr);
Error_Msg
(Flags, "\variables cannot be associative arrays", Token_Ptr);
Scan (In_Tree);
Expect (Tok_String_Literal, "literal string");
@ -1227,7 +1243,8 @@ package body Prj.Strt is
Expr_Kind : in out Variable_Kind;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Optional_Index : Boolean)
Optional_Index : Boolean;
Flags : Processing_Flags)
is
Next_Term : Project_Node_Id := Empty_Node;
Term_Id : Project_Node_Id := Empty_Node;
@ -1263,7 +1280,7 @@ package body Prj.Strt is
Expr_Kind := List;
Error_Msg
("literal string list cannot appear in a string",
(Flags, "literal string list cannot appear in a string",
Token_Ptr);
end case;
@ -1294,6 +1311,7 @@ package body Prj.Strt is
Parse_Expression
(In_Tree => In_Tree,
Expression => Next_Expression,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);
@ -1301,7 +1319,7 @@ package body Prj.Strt is
-- The expression kind is String list, report an error
if Expression_Kind_Of (Next_Expression, In_Tree) = List then
Error_Msg ("single expression expected",
Error_Msg (Flags, "single expression expected",
Current_Location);
end if;
@ -1358,7 +1376,7 @@ package body Prj.Strt is
if Token = Tok_At then
if not Optional_Index then
Error_Msg ("index not allowed here", Token_Ptr);
Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
if Token = Tok_Integer_Literal then
@ -1376,7 +1394,8 @@ package body Prj.Strt is
Index : constant Int := UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
Error_Msg
(Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Term_Id, In_Tree, To => Index);
@ -1396,6 +1415,7 @@ package body Prj.Strt is
Parse_Variable_Reference
(In_Tree => In_Tree,
Variable => Reference,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Current_Term (Term, In_Tree, To => Reference);
@ -1417,7 +1437,8 @@ package body Prj.Strt is
Expr_Kind := List;
Error_Msg
("list variable cannot appear in single string expression",
(Flags,
"list variable cannot appear in single string expression",
Current_Location);
end if;
end if;
@ -1435,6 +1456,7 @@ package body Prj.Strt is
Attribute_Reference
(In_Tree => In_Tree,
Reference => Reference,
Flags => Flags,
First_Attribute => Prj.Attr.Attribute_First,
Current_Project => Current_Project,
Current_Package => Empty_Node);
@ -1451,7 +1473,7 @@ package body Prj.Strt is
and then Expression_Kind_Of (Reference, In_Tree) = List
then
Error_Msg
("lists cannot appear in single string expression",
(Flags, "lists cannot appear in single string expression",
Current_Location);
end if;
end if;
@ -1466,13 +1488,14 @@ package body Prj.Strt is
External_Reference
(In_Tree => In_Tree,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
External_Value => Reference);
Set_Current_Term (Term, In_Tree, To => Reference);
when others =>
Error_Msg ("cannot be part of an expression", Token_Ptr);
Error_Msg (Flags, "cannot be part of an expression", Token_Ptr);
Term := Empty_Node;
return;
end case;
@ -1486,6 +1509,7 @@ package body Prj.Strt is
(In_Tree => In_Tree,
Term => Next_Term,
Expr_Kind => Expr_Kind,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);

17
gcc/ada/prj-strt.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, 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- --
@ -31,7 +31,8 @@ private package Prj.Strt is
procedure Parse_String_Type_List
(In_Tree : Project_Node_Tree_Ref;
First_String : out Project_Node_Id);
First_String : out Project_Node_Id;
Flags : Processing_Flags);
-- Get the list of literal strings that are allowed for a typed string.
-- On entry, the current token is the first literal string following
-- a left parenthesis in a string type declaration such as:
@ -58,7 +59,8 @@ private package Prj.Strt is
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr);
Case_Location : Source_Ptr;
Flags : Processing_Flags);
-- This procedure is called at the end of a case construction
-- to remove the case labels and to restore the previous state.
-- In particular, in the case of nested case constructions,
@ -69,7 +71,8 @@ private package Prj.Strt is
procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref;
First_Choice : out Project_Node_Id);
First_Choice : out Project_Node_Id;
Flags : Processing_Flags);
-- Get the label for a choice list.
-- Report an error if
-- - a case label is not a literal string
@ -81,7 +84,8 @@ private package Prj.Strt is
Expression : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Optional_Index : Boolean);
Optional_Index : Boolean;
Flags : Processing_Flags);
-- Parse a simple string expression or a string list expression.
-- Current_Project is the node of the project file being parsed.
-- Current_Package is the node of the package being parsed,
@ -93,7 +97,8 @@ private package Prj.Strt is
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Parse a variable or attribute reference.
-- Used internally (in expressions) and for case variables (in Prj.Dect).
-- Current_Package is the node of the package being parsed,

5
gcc/ada/prj.adb
View File

@ -299,7 +299,8 @@ package body Prj is
procedure Expect (The_Token : Token_Type; Token_Image : String) is
begin
if Token /= The_Token then
Error_Msg (Token_Image & " expected", Token_Ptr);
-- ??? Should pass user flags here instead
Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
end if;
end Expect;
@ -1179,7 +1180,7 @@ package body Prj is
------------------
function Create_Flags
(Report_Error : Put_Line_Access;
(Report_Error : Error_Handler;
When_No_Sources : Error_Warning;
Require_Sources_Other_Lang : Boolean := True;
Allow_Duplicate_Basenames : Boolean := True;

122
gcc/ada/prj.ads
View File

@ -96,16 +96,6 @@ package Prj is
-- constants, because Canonical_Case_File_Name is called on these variables
-- in the body of Prj.
type Error_Warning is (Silent, Warning, Error);
-- Severity of some situations, such as: no Ada sources in a project where
-- Ada is one of the language.
--
-- When the situation occurs, the behaviour depends on the setting:
--
-- - Silent: no action
-- - Warning: issue a warning, does not cause the tool to fail
-- - Error: issue an error, causes the tool to fail
function Empty_File return File_Name_Type;
function Empty_String return Name_Id;
-- Return the id for an empty string ""
@ -1290,12 +1280,6 @@ package Prj is
end record;
-- Data for a project tree
type Put_Line_Access is access procedure
(Line : String;
Project : Project_Id;
In_Tree : Project_Tree_Ref);
-- Use to customize error reporting in Prj.Proc and Prj.Nmsc
procedure Expect (The_Token : Token_Type; Token_Image : String);
-- Check that the current token is The_Token. If it is not, then output
-- an error message.
@ -1308,47 +1292,6 @@ package Prj is
-- This procedure resets all the tables that are used when processing a
-- project file tree. Initialize must be called before the call to Reset.
type Processing_Flags is private;
-- Flags used while parsing and processing a project tree to configure the
-- behavior of the parser, and indicate how to report error messages. This
-- structure does not allocate memory and never needs to be freed
function Create_Flags
(Report_Error : Put_Line_Access;
When_No_Sources : Error_Warning;
Require_Sources_Other_Lang : Boolean := True;
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
Error_On_Unknown_Language : Boolean := True) return Processing_Flags;
-- Function used to create Processing_Flags structure
--
-- If Allow_Duplicate_Basenames, then files with the same base names are
-- authorized within a project for source-based languages (never for unit
-- based languages).
--
-- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute
-- for each language must be defined, or we will not look for its source
-- files.
--
-- When_No_Sources indicates what should be done when no sources of a
-- language are found in a project where this language is declared.
-- If Require_Sources_Other_Lang is true, then all languages must have at
-- least one source file, or an error is reported via When_No_Sources. If
-- it is false, this is only required for Ada (and only if it is a language
-- of the project). When this parameter is set to False, we do not check
-- that a proper naming scheme is defined for languages other than Ada.
--
-- If Report_Error is null, use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.
--
-- If Error_On_Unknown_Language is true, an error is displayed if some of
-- the source files listed in the project do not match any naming scheme
Gprbuild_Flags : constant Processing_Flags;
Gnatmake_Flags : constant Processing_Flags;
-- Flags used by the various tools. They all display the error messages
-- through Prj.Err.
package Project_Boolean_Htable is new Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
@ -1399,6 +1342,69 @@ package Prj is
(Source_File_Name : File_Name_Type) return File_Name_Type;
-- Returns the switches file name corresponding to a source file name
-----------
-- Flags --
-----------
type Processing_Flags is private;
-- Flags used while parsing and processing a project tree to configure the
-- behavior of the parser, and indicate how to report error messages. This
-- structure does not allocate memory and never needs to be freed
type Error_Warning is (Silent, Warning, Error);
-- Severity of some situations, such as: no Ada sources in a project where
-- Ada is one of the language.
--
-- When the situation occurs, the behaviour depends on the setting:
--
-- - Silent: no action
-- - Warning: issue a warning, does not cause the tool to fail
-- - Error: issue an error, causes the tool to fail
type Error_Handler is access procedure
(Project : Project_Id; Is_Warning : Boolean);
-- This warngs when an error was found when parsing a project. The error
-- itself is handled through Prj.Err (and you should call
-- Prj.Err.Finalize to actually print the error). This ensures that
-- duplicate error messages are always correctly removed, that errors msgs
-- are sorted, and that all tools will report the same error to the user.
function Create_Flags
(Report_Error : Error_Handler;
When_No_Sources : Error_Warning;
Require_Sources_Other_Lang : Boolean := True;
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
Error_On_Unknown_Language : Boolean := True) return Processing_Flags;
-- Function used to create Processing_Flags structure
--
-- If Allow_Duplicate_Basenames, then files with the same base names are
-- authorized within a project for source-based languages (never for unit
-- based languages).
--
-- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute
-- for each language must be defined, or we will not look for its source
-- files.
--
-- When_No_Sources indicates what should be done when no sources of a
-- language are found in a project where this language is declared.
-- If Require_Sources_Other_Lang is true, then all languages must have at
-- least one source file, or an error is reported via When_No_Sources. If
-- it is false, this is only required for Ada (and only if it is a language
-- of the project). When this parameter is set to False, we do not check
-- that a proper naming scheme is defined for languages other than Ada.
--
-- If Report_Error is null, use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.
--
-- If Error_On_Unknown_Language is true, an error is displayed if some of
-- the source files listed in the project do not match any naming scheme
Gprbuild_Flags : constant Processing_Flags;
Gnatmake_Flags : constant Processing_Flags;
-- Flags used by the various tools. They all display the error messages
-- through Prj.Err.
----------------
-- Temp Files --
----------------
@ -1494,7 +1500,7 @@ private
type Processing_Flags is record
Require_Sources_Other_Lang : Boolean;
Report_Error : Put_Line_Access;
Report_Error : Error_Handler;
When_No_Sources : Error_Warning;
Allow_Duplicate_Basenames : Boolean;
Compiler_Driver_Mandatory : Boolean;