diff options
-rw-r--r-- | gcc/ada/ChangeLog | 9 | ||||
-rw-r--r-- | gcc/ada/errutil.adb | 2 | ||||
-rw-r--r-- | gcc/ada/errutil.ads | 2 | ||||
-rw-r--r-- | gcc/ada/gnatname.adb | 3 | ||||
-rw-r--r-- | gcc/ada/prj-conf.adb | 6 | ||||
-rw-r--r-- | gcc/ada/prj-dect.adb | 156 | ||||
-rw-r--r-- | gcc/ada/prj-dect.ads | 5 | ||||
-rw-r--r-- | gcc/ada/prj-err.adb | 51 | ||||
-rw-r--r-- | gcc/ada/prj-err.ads | 49 | ||||
-rw-r--r-- | gcc/ada/prj-makr.adb | 4 | ||||
-rw-r--r-- | gcc/ada/prj-makr.ads | 5 | ||||
-rw-r--r-- | gcc/ada/prj-nmsc.adb | 694 | ||||
-rw-r--r-- | gcc/ada/prj-pars.adb | 1 | ||||
-rw-r--r-- | gcc/ada/prj-part.adb | 114 | ||||
-rw-r--r-- | gcc/ada/prj-part.ads | 3 | ||||
-rw-r--r-- | gcc/ada/prj-proc.adb | 142 | ||||
-rw-r--r-- | gcc/ada/prj-strt.adb | 98 | ||||
-rw-r--r-- | gcc/ada/prj-strt.ads | 17 | ||||
-rw-r--r-- | gcc/ada/prj.adb | 5 | ||||
-rw-r--r-- | gcc/ada/prj.ads | 122 |
20 files changed, 722 insertions, 766 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7a69421..4108429 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 28c0140..28db086 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -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- -- diff --git a/gcc/ada/errutil.ads b/gcc/ada/errutil.ads index 440f69b..91ac4f1 100644 --- a/gcc/ada/errutil.ads +++ b/gcc/ada/errutil.ads @@ -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- -- diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 4e02cca..4c6d00b 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -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 diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index b29082d..b258ee9 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -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; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 001b259..9b8baf3 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -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)) & """", diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads index d5a592d..2af6e27 100644 --- a/gcc/ada/prj-dect.ads +++ b/gcc/ada/prj-dect.ads @@ -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 diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb index 9ed4cb4..abe4224 100644 --- a/gcc/ada/prj-err.adb +++ b/gcc/ada/prj-err.adb @@ -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; diff --git a/gcc/ada/prj-err.ads b/gcc/ada/prj-err.ads index e937c35..e697e19 100644 --- a/gcc/ada/prj-err.ads +++ b/gcc/ada/prj-err.ads @@ -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; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 7ae8c3d9..0f91936 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -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); diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads index b3a658f..91543a2 100644 --- a/gcc/ada/prj-makr.ads +++ b/gcc/ada/prj-makr.ads @@ -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. -- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1436c96..3ad892a 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -31,7 +31,7 @@ with Err_Vars; use Err_Vars; with Opt; use Opt; with Osint; use Osint; with Output; use Output; -with Prj.Err; +with Prj.Err; use Prj.Err; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; @@ -199,8 +199,9 @@ package body Prj.Nmsc is Naming_Exception : Boolean := False; Path : Path_Information := No_Path_Information; Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; Location : Source_Ptr := No_Location); -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a @@ -280,17 +281,6 @@ package body Prj.Nmsc is -- Return the index of the last significant character in Dir. This is used -- to avoid duplicate '/' (slash) characters at the end of directory names. - procedure Error_Msg - (Project : Project_Id; - Msg : String; - Flag_Location : Source_Ptr; - Data : Tree_Processing_Data); - -- Output an error message. If Data.Error_Report is null, simply call - -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use - -- Error_Report. If Msg starts with "?", this is a warning, and the - -- string "Warning:" is prepended to the message. If Msg starts with "<", - -- see comment for Err_Vars.Error_Msg_Warn. - procedure Search_Directories (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data; @@ -552,8 +542,9 @@ package body Prj.Nmsc is Naming_Exception : Boolean := False; Path : Path_Information := No_Path_Information; Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; Location : Source_Ptr := No_Location) is Config : constant Language_Config := Lang_Id.Config; @@ -608,8 +599,8 @@ package body Prj.Nmsc is else Error_Msg_File_1 := File_Name; Error_Msg - (Project, "duplicate source file name {", - Location, Data); + (Data.Flags, "duplicate source file name {", + Location, Project); Add_Src := False; end if; @@ -623,7 +614,7 @@ package body Prj.Nmsc is elsif Source.Path.Name /= Path.Name then Error_Msg_Name_1 := Unit; Error_Msg - (Project, "duplicate unit %%", Location, Data); + (Data.Flags, "duplicate unit %%", Location, Project); Add_Src := False; end if; end if; @@ -636,7 +627,9 @@ package body Prj.Nmsc is -- to have the same file name in unrelated projects. elsif Is_Extending (Project, Source.Project) then - Source_To_Replace := Source; + if not Locally_Removed then + Source_To_Replace := Source; + end if; elsif Prev_Unit /= No_Unit_Index and then not Source.Locally_Removed @@ -649,26 +642,26 @@ package body Prj.Nmsc is if Path /= No_Path_Information then Error_Msg_Name_1 := Unit; Error_Msg - (Project, + (Data.Flags, "unit %% cannot belong to several projects", - Location, Data); + Location, Project); Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Name_Id (Path.Name); Error_Msg - (Project, "\ project %%, %%", Location, Data); + (Data.Flags, "\ project %%, %%", Location, Project); Error_Msg_Name_1 := Source.Project.Name; Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); Error_Msg - (Project, "\ project %%, %%", Location, Data); + (Data.Flags, "\ project %%, %%", Location, Project); else Error_Msg_Name_1 := Unit; Error_Msg_Name_2 := Source.Project.Name; Error_Msg - (Project, "unit %% already belongs to project %%", - Location, Data); + (Data.Flags, "unit %% already belongs to project %%", + Location, Project); end if; Add_Src := False; @@ -680,8 +673,8 @@ package body Prj.Nmsc is Error_Msg_File_1 := File_Name; Error_Msg_File_2 := File_Name_Type (Source.Project.Name); Error_Msg - (Project, - "{ is already a source of project {", Location, Data); + (Data.Flags, + "{ is already a source of project {", Location, Project); -- Add the file anyway, to avoid further warnings like "language -- unknown". @@ -727,6 +720,7 @@ package body Prj.Nmsc is Id.Language := Lang_Id; Id.Kind := Kind; Id.Alternate_Languages := Alternate_Languages; + Id.Locally_Removed := Locally_Removed; -- Add the source id to the Unit_Sources_HT hash table, if the unit name -- is not null. @@ -848,10 +842,10 @@ package body Prj.Nmsc is else Error_Msg - (Project, + (Data.Flags, "at least one of Source_Files, Source_Dirs or Languages " & "must be declared empty for an abstract project", - Project.Location, Data); + Project.Location, Project); end if; end; end if; @@ -1374,8 +1368,8 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, "include option cannot be null", - Element.Value.Location, Data); + (Data.Flags, "include option cannot be null", + Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Include_Option, @@ -1427,15 +1421,17 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, "invalid value for Path_Syntax", - Element.Value.Location, Data); + (Data.Flags, + "invalid value for Path_Syntax", + Element.Value.Location, Project); end; when Name_Object_File_Suffix => if Get_Name_String (Element.Value.Value) = "" then Error_Msg - (Project, "object file suffix cannot be empty", - Element.Value.Location, Data); + (Data.Flags, + "object file suffix cannot be empty", + Element.Value.Location, Project); else Lang_Index.Config.Object_File_Suffix := @@ -1456,8 +1452,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, "compiler PIC option cannot be null", - Element.Value.Location, Data); + (Data.Flags, + "compiler PIC option cannot be null", + Element.Value.Location, Project); end if; Put (Into_List => @@ -1473,9 +1470,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "mapping file switches cannot be null", - Element.Value.Location, Data); + Element.Value.Location, Project); end if; Put (Into_List => @@ -1505,9 +1502,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "config file switches cannot be null", - Element.Value.Location, Data); + Element.Value.Location, Project); end if; Put (Into_List => @@ -1570,9 +1567,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "illegal value for Config_File_Unique", - Element.Value.Location, Data); + Element.Value.Location, Project); end; when others => @@ -1623,9 +1620,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value for Casing", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Dot_Replacement then @@ -1754,9 +1751,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "value must be positive or equal to 0", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Response_File_Format then @@ -1782,9 +1779,9 @@ package body Prj.Nmsc is else Error_Msg - (Project, + (Data.Flags, "illegal response file format", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; end; @@ -1887,9 +1884,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "archive builder cannot be null", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Archive_Builder, @@ -1921,9 +1918,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "archive indexer cannot be null", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Archive_Indexer, @@ -1940,9 +1937,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "partial linker cannot be null", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Lib_Partial_Linker, @@ -1953,10 +1950,10 @@ package body Prj.Nmsc is Project.Config.Shared_Lib_Driver := File_Name_Type (Attribute.Value.Value); Error_Msg - (Project, + (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, " & "use Linker''Driver instead", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); elsif Attribute.Name = Name_Archive_Suffix then Project.Config.Archive_Suffix := @@ -1971,9 +1968,9 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, + (Data.Flags, "linker executable option cannot be null", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Linker_Executable_Option, @@ -1990,9 +1987,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "linker library directory option cannot be empty", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Dir_Option := @@ -2008,9 +2005,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "linker library name option cannot be empty", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Name_Option := @@ -2038,11 +2035,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Separate_Run_Path_Options", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Support then @@ -2055,11 +2052,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Support", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Prefix then @@ -2080,11 +2077,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Symbolic_Link_Supported", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif @@ -2099,11 +2096,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Major_Minor_Id_Supported", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Auto_Init_Supported then @@ -2115,11 +2112,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Auto_Init_Supported", - Attribute.Value.Location, Data); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then @@ -2238,11 +2235,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Element.Value.Value) & """ for Object_Generated", - Element.Value.Location, Data); + Element.Value.Location, Project); end; when Name_Objects_Linked => @@ -2265,11 +2262,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, + (Data.Flags, "invalid value """ & Get_Name_String (Element.Value.Value) & """ for Objects_Linked", - Element.Value.Location, Data); + Element.Value.Location, Project); end; when others => null; @@ -2336,10 +2333,10 @@ package body Prj.Nmsc is then Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg - (Project, + (Data.Flags, "?no compiler specified for language %%" & ", ignoring all its sources", - No_Location, Data); + No_Location, Project); if Lang_Index = Project.Languages then Project.Languages := Lang_Index.Next; @@ -2355,23 +2352,23 @@ package body Prj.Nmsc is if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then Error_Msg - (Project, + (Data.Flags, "Dot_Replacement not specified for Ada", - No_Location, Data); + No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then Error_Msg - (Project, + (Data.Flags, "Spec_Suffix not specified for Ada", - No_Location, Data); + No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg - (Project, + (Data.Flags, "Body_Suffix not specified for Ada", - No_Location, Data); + No_Location, Project); end if; else @@ -2386,9 +2383,9 @@ package body Prj.Nmsc is then Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg - (Project, + (Data.Flags, "no suffixes specified for %%", - No_Location, Data); + No_Location, Project); end if; end if; @@ -2418,9 +2415,9 @@ package body Prj.Nmsc is Project.Externally_Built := True; elsif Name_Buffer (1 .. Name_Len) /= "false" then - Error_Msg (Project, + Error_Msg (Data.Flags, "Externally_Built may only be true or false", - Externally_Built.Location, Data); + Externally_Built.Location, Project); end if; end if; @@ -2529,10 +2526,10 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Project.Name; Error_Msg - (Project, + (Data.Flags, "{ cannot be an interface of project %% " & "as it is not one of its sources", - Element.Location, Data); + Element.Location, Project); end if; List := Element.Next; @@ -2635,8 +2632,8 @@ package body Prj.Nmsc is if Length_Of_Name (Dot_Repl.Value) = 0 then Error_Msg - (Project, "Dot_Replacement cannot be empty", - Dot_Repl.Location, Data); + (Data.Flags, "Dot_Replacement cannot be empty", + Dot_Repl.Location, Project); end if; Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); @@ -2666,10 +2663,10 @@ package body Prj.Nmsc is Index (Source => Repl, Pattern => ".") /= 0) then Error_Msg - (Project, + (Data.Flags, '"' & Repl & """ is illegal for Dot_Replacement.", - Dot_Repl_Loc, Data); + Dot_Repl_Loc, Project); end if; end; end if; @@ -2692,9 +2689,9 @@ package body Prj.Nmsc is begin if Casing_Image'Length = 0 then Error_Msg - (Project, + (Data.Flags, "Casing cannot be an empty string", - Casing_String.Location, Data); + Casing_String.Location, Project); end if; Casing := Value (Casing_Image); @@ -2706,9 +2703,9 @@ package body Prj.Nmsc is Name_Buffer (1 .. Name_Len) := Casing_Image; Err_Vars.Error_Msg_Name_1 := Name_Find; Error_Msg - (Project, + (Data.Flags, "%% is not a correct Casing", - Casing_String.Location, Data); + Casing_String.Location, Project); end; end if; @@ -2717,9 +2714,9 @@ package body Prj.Nmsc is if not Sep_Suffix.Default then if Length_Of_Name (Sep_Suffix.Value) = 0 then Error_Msg - (Project, + (Data.Flags, "Separate_Suffix cannot be empty", - Sep_Suffix.Location, Data); + Sep_Suffix.Location, Project); else Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); @@ -2807,15 +2804,15 @@ package body Prj.Nmsc is if Source.Language /= Lang_Id then Error_Msg - (Project, + (Data.Flags, "the same file cannot be a source of two languages", - Element.Location, Data); + Element.Location, Project); elsif Source.Kind /= Kind then Error_Msg - (Project, + (Data.Flags, "the same file cannot be a source and a template", - Element.Location, Data); + Element.Location, Project); end if; -- If the file is already recorded for the same @@ -2896,9 +2893,9 @@ package body Prj.Nmsc is if Unit = No_Name then Err_Vars.Error_Msg_Name_1 := Element.Index; Error_Msg - (Project, + (Data.Flags, "%% is not a valid unit name.", - Element.Value.Location, Data); + Element.Value.Location, Project); end if; end if; @@ -3070,11 +3067,11 @@ package body Prj.Nmsc is Lang_Id.Config.Naming_Data.Body_Suffix then Error_Msg - (Project, + (Data.Flags, "Body_Suffix (""" & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) & """) cannot be the same as Spec_Suffix.", - Ada_Body_Suffix_Loc, Data); + Ada_Body_Suffix_Loc, Project); end if; if Lang_Id.Config.Naming_Data.Body_Suffix /= @@ -3083,12 +3080,12 @@ package body Prj.Nmsc is Lang_Id.Config.Naming_Data.Separate_Suffix then Error_Msg - (Project, + (Data.Flags, "Separate_Suffix (""" & Get_Name_String (Lang_Id.Config.Naming_Data.Separate_Suffix) & """) cannot be the same as Spec_Suffix.", - Sep_Suffix_Loc, Data); + Sep_Suffix_Loc, Project); end if; Lang_Id := Lang_Id.Next; @@ -3318,11 +3315,11 @@ package body Prj.Nmsc is if Extends then if Project.Library_Kind /= Static then Error_Msg - (Project, + (Data.Flags, Continuation.all & "shared library project %% cannot extend " & "project %% that is not a library project", - Project.Location, Data); + Project.Location, Project); Continuation := Continuation_String'Access; end if; @@ -3330,11 +3327,11 @@ package body Prj.Nmsc is and then Project.Library_Kind /= Static then Error_Msg - (Project, + (Data.Flags, Continuation.all & "shared library project %% cannot import project %% " & "that is not a shared library project", - Project.Location, Data); + Project.Location, Project); Continuation := Continuation_String'Access; end if; end if; @@ -3347,20 +3344,20 @@ package body Prj.Nmsc is if Extends then Error_Msg - (Project, + (Data.Flags, Continuation.all & "shared library project %% cannot extend static " & "library project %%", - Project.Location, Data); + Project.Location, Project); Continuation := Continuation_String'Access; elsif not Unchecked_Shared_Lib_Imports then Error_Msg - (Project, + (Data.Flags, Continuation.all & "shared library project %% cannot import static " & "library project %%", - Project.Location, Data); + Project.Location, Project); Continuation := Continuation_String'Access; end if; @@ -3386,9 +3383,9 @@ package body Prj.Nmsc is if Project.Extends.Library then if Project.Qualifier = Standard then Error_Msg - (Project, + (Data.Flags, "a standard project cannot extend a library project", - Project.Location, Data); + Project.Location, Project); else if Lib_Name.Default then @@ -3398,10 +3395,10 @@ package body Prj.Nmsc is if Lib_Dir.Default then if not Project.Virtual then Error_Msg - (Project, + (Data.Flags, "a project extending a library project must " & "specify an attribute Library_Dir", - Project.Location, Data); + Project.Location, Project); else -- For a virtual project extending a library project, @@ -3473,19 +3470,19 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_Dir.Display_Name); Error_Msg - (Project, + (Data.Flags, "library directory { does not exist", - Lib_Dir.Location, Data); + Lib_Dir.Location, Project); -- The library directory cannot be the same as the Object -- directory. elsif Project.Library_Dir.Name = Project.Object_Directory.Name then Error_Msg - (Project, + (Data.Flags, "library directory cannot be the same " & "as object directory", - Lib_Dir.Location, Data); + Lib_Dir.Location, Project); Project.Library_Dir := No_Path_Information; else @@ -3510,10 +3507,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg - (Project, + (Data.Flags, "library directory cannot be the same " & "as source directory {", - Lib_Dir.Location, Data); + Lib_Dir.Location, Project); OK := False; exit; end if; @@ -3544,10 +3541,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_Name_1 := Pid.Project.Name; Error_Msg - (Project, + (Data.Flags, "library directory cannot be the same " & "as source directory { of project %%", - Lib_Dir.Location, Data); + Lib_Dir.Location, Project); OK := False; exit Project_Loop; end if; @@ -3584,25 +3581,25 @@ package body Prj.Nmsc is when Standard => if Project.Library then Error_Msg - (Project, + (Data.Flags, "a standard project cannot be a library project", - Lib_Name.Location, Data); + Lib_Name.Location, Project); end if; when Library => if not Project.Library then if Project.Library_Dir = No_Path_Information then Error_Msg - (Project, + (Data.Flags, "\attribute Library_Dir not declared", - Project.Location, Data); + Project.Location, Project); end if; if Project.Library_Name = No_Name then Error_Msg - (Project, + (Data.Flags, "\attribute Library_Name not declared", - Project.Location, Data); + Project.Location, Project); end if; end if; @@ -3617,9 +3614,9 @@ package body Prj.Nmsc is if Support_For_Libraries = Prj.None then Error_Msg - (Project, + (Data.Flags, "?libraries are not supported on this platform", - Lib_Name.Location, Data); + Lib_Name.Location, Project); Project.Library := False; else @@ -3652,9 +3649,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_ALI_Dir.Display_Name); Error_Msg - (Project, + (Data.Flags, "library 'A'L'I directory { does not exist", - Lib_ALI_Dir.Location, Data); + Lib_ALI_Dir.Location, Project); end if; if Project.Library_ALI_Dir /= Project.Library_Dir then @@ -3664,10 +3661,10 @@ package body Prj.Nmsc is if Project.Library_ALI_Dir = Project.Object_Directory then Error_Msg - (Project, + (Data.Flags, "library 'A'L'I directory cannot be the same " & "as object directory", - Lib_ALI_Dir.Location, Data); + Lib_ALI_Dir.Location, Project); Project.Library_ALI_Dir := No_Path_Information; else @@ -3693,10 +3690,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg - (Project, + (Data.Flags, "library 'A'L'I directory cannot be " & "the same as source directory {", - Lib_ALI_Dir.Location, Data); + Lib_ALI_Dir.Location, Project); OK := False; exit; end if; @@ -3730,11 +3727,11 @@ package body Prj.Nmsc is Pid.Project.Name; Error_Msg - (Project, + (Data.Flags, "library 'A'L'I directory cannot " & "be the same as source directory " & "{ of project %%", - Lib_ALI_Dir.Location, Data); + Lib_ALI_Dir.Location, Project); OK := False; exit ALI_Project_Loop; end if; @@ -3800,9 +3797,9 @@ package body Prj.Nmsc is else Error_Msg - (Project, + (Data.Flags, "illegal value for Library_Kind", - The_Lib_Kind.Location, Data); + The_Lib_Kind.Location, Project); OK := False; end if; @@ -3813,10 +3810,10 @@ package body Prj.Nmsc is if Project.Library_Kind /= Static then if Support_For_Libraries = Prj.Static_Only then Error_Msg - (Project, + (Data.Flags, "only static libraries are supported " & "on this platform", - The_Lib_Kind.Location, Data); + The_Lib_Kind.Location, Project); Project.Library := False; else @@ -3825,10 +3822,10 @@ package body Prj.Nmsc is if Lib_GCC.Value /= Empty_String then Error_Msg - (Project, + (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, " & "use Linker''Driver instead", - Lib_GCC.Location, Data); + Lib_GCC.Location, Project); Project.Config.Shared_Lib_Driver := File_Name_Type (Lib_GCC.Value); @@ -3913,10 +3910,10 @@ package body Prj.Nmsc is if Switches /= No_Array_Element then Error_Msg - (Project, + (Data.Flags, "?Linker switches not taken into account in library " & "projects", - No_Location, Data); + No_Location, Project); end if; end if; end; @@ -3994,9 +3991,9 @@ package body Prj.Nmsc is if Def_Lang.Default then Error_Msg - (Project, + (Data.Flags, "no languages defined for this project", - Project.Location, Data); + Project.Location, Project); Def_Lang_Id := No_Name; else @@ -4026,9 +4023,9 @@ package body Prj.Nmsc is if Project.Qualifier = Standard then Error_Msg - (Project, + (Data.Flags, "a standard project must have at least one language", - Languages.Location, Data); + Languages.Location, Project); end if; else @@ -4123,9 +4120,9 @@ package body Prj.Nmsc is if Interfaces = Nil_String then Error_Msg - (Project, + (Data.Flags, "Library_Interface cannot be an empty list", - Lib_Interfaces.Location, Data); + Lib_Interfaces.Location, Project); end if; -- Process each unit name specified in the attribute @@ -4138,10 +4135,10 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "an interface cannot be an empty string", Data.Tree.String_Elements.Table (Interfaces).Location, - Data); + Project); else Unit := Name_Find; @@ -4187,10 +4184,10 @@ package body Prj.Nmsc is if Source = No_Source then Error_Msg - (Project, + (Data.Flags, "%% is not a unit of this project", Data.Tree.String_Elements.Table - (Interfaces).Location, Data); + (Interfaces).Location, Project); else if Source.Kind = Spec @@ -4253,17 +4250,17 @@ package body Prj.Nmsc is -- supported. Error_Msg - (Project, + (Data.Flags, "library auto init not supported " & "on this platform", - Lib_Auto_Init.Location, Data); + Lib_Auto_Init.Location, Project); end if; else Error_Msg - (Project, + (Data.Flags, "invalid value for attribute Library_Auto_Init", - Lib_Auto_Init.Location, Data); + Lib_Auto_Init.Location, Project); end if; end if; end; @@ -4302,18 +4299,18 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_Src_Dir.Display_Name); Error_Msg - (Project, + (Data.Flags, "Directory { does not exist", - Lib_Src_Dir.Location, Data); + Lib_Src_Dir.Location, Project); -- Report error if it is the same as the object directory elsif Project.Library_Src_Dir = Project.Object_Directory then Error_Msg - (Project, + (Data.Flags, "directory to copy interfaces cannot be " & "the object directory", - Lib_Src_Dir.Location, Data); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; else @@ -4336,10 +4333,10 @@ package body Prj.Nmsc is Path_Name_Type (Src_Dir.Value) then Error_Msg - (Project, + (Data.Flags, "directory to copy interfaces cannot " & "be one of the source directories", - Lib_Src_Dir.Location, Data); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit; end if; @@ -4371,11 +4368,11 @@ package body Prj.Nmsc is File_Name_Type (Src_Dir.Value); Error_Msg_Name_1 := Pid.Project.Name; Error_Msg - (Project, + (Data.Flags, "directory to copy interfaces cannot " & "be the same as source directory { of " & "project %%", - Lib_Src_Dir.Location, Data); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit Project_Loop; @@ -4433,9 +4430,9 @@ package body Prj.Nmsc is else Error_Msg - (Project, + (Data.Flags, "illegal value for Library_Symbol_Policy", - Lib_Symbol_Policy.Location, Data); + Lib_Symbol_Policy.Location, Project); end if; end; end if; @@ -4446,10 +4443,10 @@ package body Prj.Nmsc is if Lib_Symbol_File.Default then if Project.Symbol_Data.Symbol_Policy = Restricted then Error_Msg - (Project, + (Data.Flags, "Library_Symbol_File needs to be defined when " & "symbol policy is Restricted", - Lib_Symbol_Policy.Location, Data); + Lib_Symbol_Policy.Location, Project); end if; else @@ -4462,9 +4459,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "symbol file name cannot be an empty string", - Lib_Symbol_File.Location, Data); + Lib_Symbol_File.Location, Project); else OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); @@ -4483,10 +4480,10 @@ package body Prj.Nmsc is if not OK then Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value); Error_Msg - (Project, + (Data.Flags, "symbol file name { is illegal. " & "Name cannot include directory info.", - Lib_Symbol_File.Location, Data); + Lib_Symbol_File.Location, Project); end if; end if; end if; @@ -4499,9 +4496,9 @@ package body Prj.Nmsc is or else Project.Symbol_Data.Symbol_Policy = Controlled then Error_Msg - (Project, + (Data.Flags, "a reference symbol file needs to be defined", - Lib_Symbol_Policy.Location, Data); + Lib_Symbol_Policy.Location, Project); end if; else @@ -4514,9 +4511,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "reference symbol file name cannot be an empty string", - Lib_Symbol_File.Location, Data); + Lib_Symbol_File.Location, Project); else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then @@ -4543,9 +4540,9 @@ package body Prj.Nmsc is and then Project.Symbol_Data.Symbol_Policy /= Direct; Error_Msg - (Project, + (Data.Flags, "<library reference symbol file { does not exist", - Lib_Ref_Symbol_File.Location, Data); + Lib_Ref_Symbol_File.Location, Project); -- In addition in the non-controlled case, if symbol policy -- is Compliant, it is changed to Autonomous, because there @@ -4589,10 +4586,10 @@ package body Prj.Nmsc is begin if Symb_Path = Ref_Path then Error_Msg - (Project, + (Data.Flags, "library reference symbol file and library" & " symbol file cannot be the same file", - Lib_Ref_Symbol_File.Location, Data); + Lib_Ref_Symbol_File.Location, Project); end if; end; end if; @@ -4619,171 +4616,6 @@ package body Prj.Nmsc is end if; end Compute_Directory_Last; - --------------- - -- Error_Msg -- - --------------- - - procedure Error_Msg - (Project : Project_Id; - Msg : String; - Flag_Location : Source_Ptr; - Data : Tree_Processing_Data) - is - Real_Location : Source_Ptr := Flag_Location; - Error_Buffer : String (1 .. 5_000); - Error_Last : Natural := 0; - Name_Number : Natural := 0; - File_Number : Natural := 0; - First : Positive := Msg'First; - Index : Positive; - - procedure Add (C : Character); - -- Add a character to the buffer - - procedure Add (S : String); - -- Add a string to the buffer - - procedure Add_Name; - -- Add a name to the buffer - - procedure Add_File; - -- Add a file name to the buffer - - --------- - -- Add -- - --------- - - procedure Add (C : Character) is - begin - Error_Last := Error_Last + 1; - Error_Buffer (Error_Last) := C; - end Add; - - procedure Add (S : String) is - begin - Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S; - Error_Last := Error_Last + S'Length; - end Add; - - -------------- - -- Add_File -- - -------------- - - procedure Add_File is - File : File_Name_Type; - - begin - Add ('"'); - File_Number := File_Number + 1; - - case File_Number is - when 1 => - File := Err_Vars.Error_Msg_File_1; - when 2 => - File := Err_Vars.Error_Msg_File_2; - when 3 => - File := Err_Vars.Error_Msg_File_3; - when others => - null; - end case; - - Get_Name_String (File); - Add (Name_Buffer (1 .. Name_Len)); - Add ('"'); - end Add_File; - - -------------- - -- Add_Name -- - -------------- - - procedure Add_Name is - Name : Name_Id; - - begin - Add ('"'); - Name_Number := Name_Number + 1; - - case Name_Number is - when 1 => - Name := Err_Vars.Error_Msg_Name_1; - when 2 => - Name := Err_Vars.Error_Msg_Name_2; - when 3 => - Name := Err_Vars.Error_Msg_Name_3; - when others => - null; - end case; - - Get_Name_String (Name); - Add (Name_Buffer (1 .. Name_Len)); - Add ('"'); - end Add_Name; - - -- Start of processing for Error_Msg - - 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 then - Real_Location := Project.Location; - end if; - - if Data.Flags.Report_Error = null then - Prj.Err.Error_Msg (Msg, Real_Location); - return; - end if; - - -- Ignore continuation character - - if Msg (First) = '\' then - First := First + 1; - end if; - - if Msg (First) = '?' then - First := First + 1; - Add ("Warning: "); - - elsif Msg (First) = '<' then - First := First + 1; - - if Err_Vars.Error_Msg_Warn then - Add ("Warning: "); - end if; - end if; - - Index := First; - while Index <= Msg'Last loop - if Msg (Index) = '{' then - Add_File; - - elsif Msg (Index) = '%' then - if Index < Msg'Last and then Msg (Index + 1) = '%' then - Index := Index + 1; - end if; - - Add_Name; - - else - Add (Msg (Index)); - end if; - - Index := Index + 1; - - end loop; - - Data.Flags.Report_Error - (Error_Buffer (1 .. Error_Last), Project, Data.Tree); - end Error_Msg; - --------------------- -- Get_Directories -- --------------------- @@ -5078,14 +4910,14 @@ package body Prj.Nmsc is if Location = No_Location then Error_Msg - (Project, + (Data.Flags, "{ is not a valid directory.", - Project.Location, Data); + Project.Location, Project); else Error_Msg - (Project, + (Data.Flags, "{ is not a valid directory.", - Location, Data); + Location, Project); end if; else @@ -5129,14 +4961,14 @@ package body Prj.Nmsc is if Location = No_Location then Error_Msg - (Project, + (Data.Flags, "{ is not a valid directory", - Project.Location, Data); + Project.Location, Project); else Error_Msg - (Project, + (Data.Flags, "{ is not a valid directory", - Location, Data); + Location, Project); end if; else @@ -5271,9 +5103,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "Object_Dir cannot be empty", - Object_Dir.Location, Data); + Object_Dir.Location, Project); else -- We check that the specified object directory does exist. @@ -5302,9 +5134,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); Error_Msg - (Project, + (Data.Flags, "object directory { not found", - Project.Location, Data); + Project.Location, Project); end if; end if; @@ -5345,9 +5177,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, + (Data.Flags, "Exec_Dir cannot be empty", - Exec_Dir.Location, Data); + Exec_Dir.Location, Project); else -- We check that the specified exec directory does exist @@ -5365,9 +5197,9 @@ package body Prj.Nmsc is if not Dir_Exists then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg - (Project, + (Data.Flags, "exec directory { not found", - Project.Location, Data); + Project.Location, Project); end if; end if; end if; @@ -5397,9 +5229,9 @@ package body Prj.Nmsc is if Project.Qualifier = Standard then Error_Msg - (Project, + (Data.Flags, "a standard project cannot have no sources", - Source_Files.Location, Data); + Source_Files.Location, Project); end if; elsif Source_Dirs.Default then @@ -5427,9 +5259,9 @@ package body Prj.Nmsc is elsif Source_Dirs.Values = Nil_String then if Project.Qualifier = Standard then Error_Msg - (Project, + (Data.Flags, "a standard project cannot have no source directories", - Source_Dirs.Location, Data); + Source_Dirs.Location, Project); end if; Project.Source_Dirs := Nil_String; @@ -5525,9 +5357,9 @@ package body Prj.Nmsc is elsif Project.Library then Error_Msg - (Project, + (Data.Flags, "a library project file cannot have Main specified", - Mains.Location, Data); + Mains.Location, Project); else List := Mains.Values; @@ -5536,9 +5368,9 @@ package body Prj.Nmsc is if Length_Of_Name (Elem.Value) = 0 then Error_Msg - (Project, + (Data.Flags, "?a main cannot have an empty name", - Elem.Location, Data); + Elem.Location, Project); exit; end if; @@ -5575,7 +5407,8 @@ package body Prj.Nmsc is Prj.Util.Open (File, Path); if not Prj.Util.Is_Valid (File) then - Error_Msg (Project.Project, "file does not exist", Location, Data); + Error_Msg + (Data.Flags, "file does not exist", Location, Project.Project); else -- Read the lines one by one @@ -5599,9 +5432,9 @@ package body Prj.Nmsc is if Line (J) = '/' or else Line (J) = Directory_Separator then Error_Msg_File_1 := Source_Name; Error_Msg - (Project.Project, + (Data.Flags, "file name cannot include directory information ({)", - Location, Data); + Location, Project.Project); exit; end if; end loop; @@ -5889,9 +5722,9 @@ package body Prj.Nmsc is elsif Index (Suffix_Str, ".") = 0 then Err_Vars.Error_Msg_File_1 := Suffix; Error_Msg - (Project, + (Data.Flags, "{ is illegal for " & Attribute_Name & ": must have a dot", - Location, Data); + Location, Project); return; end if; @@ -5913,10 +5746,10 @@ package body Prj.Nmsc is if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then Err_Vars.Error_Msg_File_1 := Suffix; Error_Msg - (Project, + (Data.Flags, "{ is illegal for " & Attribute_Name & ": ambiguous prefix when Dot_Replacement is a dot", - Location, Data); + Location, Project); end if; return; end if; @@ -6035,10 +5868,10 @@ package body Prj.Nmsc is exception when Use_Error => Error_Msg - (Project, + (Data.Flags, "could not create " & Create & " directory " & Full_Path_Name.all, - Location, Data); + Location, Project); end; end if; end if; @@ -6137,16 +5970,16 @@ package body Prj.Nmsc is if not Excluded_Source_List_File.Default then if Locally_Removed then Error_Msg - (Project.Project, + (Data.Flags, "?both attributes Locally_Removed_Files and " & "Excluded_Source_List_File are present", - Excluded_Source_List_File.Location, Data); + Excluded_Source_List_File.Location, Project.Project); else Error_Msg - (Project.Project, + (Data.Flags, "?both attributes Excluded_Source_Files and " & "Excluded_Source_List_File are present", - Excluded_Source_List_File.Location, Data); + Excluded_Source_List_File.Location, Project.Project); end if; end if; @@ -6184,9 +6017,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Excluded_Source_List_File.Value); Error_Msg - (Project.Project, + (Data.Flags, "file with excluded sources { does not exist", - Excluded_Source_List_File.Location, Data); + Excluded_Source_List_File.Location, Project.Project); else -- Open the file @@ -6195,7 +6028,8 @@ package body Prj.Nmsc is if not Prj.Util.Is_Valid (File) then Error_Msg - (Project.Project, "file does not exist", Location, Data); + (Data.Flags, "file does not exist", + Location, Project.Project); else -- Read the lines one by one @@ -6220,10 +6054,10 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Name; Error_Msg - (Project.Project, + (Data.Flags, "file name cannot include " & "directory information ({)", - Location, Data); + Location, Project.Project); exit; end if; end loop; @@ -6276,10 +6110,10 @@ package body Prj.Nmsc is if not Sources.Default then if not Source_List_File.Default then Error_Msg - (Project.Project, + (Data.Flags, "?both attributes source_files and " & "source_list_file are present", - Source_List_File.Location, Data); + Source_List_File.Location, Project.Project); end if; -- Sources is a list of file names @@ -6328,10 +6162,10 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Name; Error_Msg - (Project.Project, + (Data.Flags, "file name cannot include directory " & "information ({)", - Location, Data); + Location, Project.Project); exit; end if; end loop; @@ -6380,9 +6214,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Source_List_File.Value); Error_Msg - (Project.Project, + (Data.Flags, "file with sources { does not exist", - Source_List_File.Location, Data); + Source_List_File.Location, Project.Project); else Get_Sources_From_File @@ -6433,10 +6267,9 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Name_Id (Source.Unit.Name); Error_Msg - (Project.Project, + (Data.Flags, "source file %% for unit %% not found", - No_Location, - Data); + No_Location, Project.Project); else Source.Path := Files_Htable.Get @@ -6480,16 +6313,16 @@ package body Prj.Nmsc is if First_Error then Error_Msg - (Project.Project, + (Data.Flags, "source file { not found", - NL.Location, Data); + NL.Location, Project.Project); First_Error := False; else Error_Msg - (Project.Project, + (Data.Flags, "\source file { not found", - NL.Location, Data); + NL.Location, Project.Project); end if; end if; @@ -6751,9 +6584,9 @@ package body Prj.Nmsc is if not Project.Project.Known_Order_Of_Source_Dirs then Error_Msg_File_1 := File_Name; Error_Msg - (Project.Project, + (Data.Flags, "{ is found in several source directories", - Name_Loc.Location, Data); + Name_Loc.Location, Project.Project); end if; else @@ -6813,9 +6646,9 @@ package body Prj.Nmsc is then Error_Msg_File_1 := File_Name; Error_Msg - (Project.Project, + (Data.Flags, "language unknown for {", - Name_Loc.Location, Data); + Name_Loc.Location, Project.Project); end if; else @@ -6829,11 +6662,8 @@ package body Prj.Nmsc is File_Name => File_Name, Display_File => Display_File_Name, Unit => Unit, + Locally_Removed => Locally_Removed, Path => (Canonical_Path, Path)); - - if Source /= No_Source then - Source.Locally_Removed := Locally_Removed; - end if; end if; end if; end Check_File; @@ -7014,9 +6844,9 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Source.File; Error_Msg - (Project.Project, + (Data.Flags, "{ cannot be both excluded and an exception file name", - No_Location, Data); + No_Location, Project.Project); end if; if Current_Verbosity = High then @@ -7102,9 +6932,9 @@ package body Prj.Nmsc is Error_Msg_File_1 := Src.File; Error_Msg_File_2 := Source.File; Error_Msg - (Project.Project, + (Data.Flags, "{ and { have the same object file name", - No_Location, Data); + No_Location, Project.Project); else Object_File_Names_Htable.Set (Object_Files, Src.Object, Src); @@ -7180,13 +7010,13 @@ package body Prj.Nmsc is if Src = No_Source then Error_Msg - (Project.Project, - "unknown file {", Excluded.Location, Data); + (Data.Flags, + "unknown file {", Excluded.Location, Project.Project); else Error_Msg - (Project.Project, + (Data.Flags, "cannot remove a source from an imported project: {", - Excluded.Location, Data); + Excluded.Location, Project.Project); end if; end if; @@ -7371,9 +7201,9 @@ package body Prj.Nmsc is Error_Msg_Warn := Data.Flags.When_No_Sources = Warning; if Continuation then - Error_Msg (Project, "\" & Msg, Location, Data); + Error_Msg (Data.Flags, "\" & Msg, Location, Project); else - Error_Msg (Project, Msg, Location, Data); + Error_Msg (Data.Flags, Msg, Location, Project); end if; end; end case; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index 83b0549..bacbf8d 100644 --- a/gcc/ada/prj-pars.adb +++ b/gcc/ada/prj-pars.adb @@ -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 diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 9115952..8a0f6a5 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -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; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 3906ad7..4e9acee 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -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, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 79a34c6..7986a9b 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -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, diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 862b6ff..0dd2e5e 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -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); diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index d0b4b59..0f6d0d0 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -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, diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index a8c22f7..e0c2f1b 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -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; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 4154e9b..27ee5f0 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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; |