diff options
Diffstat (limited to 'gcc/ada/prj-dect.adb')
| -rw-r--r-- | gcc/ada/prj-dect.adb | 532 |
1 files changed, 407 insertions, 125 deletions
diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 37513fe986b..9865dff63c1 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2002 Free Software Foundation, Inc -- +-- Copyright (C) 2001-2003 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- -- @@ -24,19 +24,22 @@ -- -- ------------------------------------------------------------------------------ -with Errout; use Errout; +with Err_Vars; use Err_Vars; with Namet; use Namet; +with Prj.Err; use Prj.Err; with Prj.Strt; use Prj.Strt; with Prj.Tree; use Prj.Tree; with Scans; use Scans; -with Sinfo; use Sinfo; +with Snames; with Types; use Types; with Prj.Attr; use Prj.Attr; package body Prj.Dect is type Zone is (In_Project, In_Package, In_Case_Construction); - -- Needs a comment ??? + -- Used to indicate if we are parsing a package (In_Package), + -- a case construction (In_Case_Construction) or none of those two + -- (In_Project). procedure Parse_Attribute_Declaration (Attribute : out Project_Node_Id; @@ -93,7 +96,7 @@ package body Prj.Dect is begin Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration); Set_Location_Of (Declarations, To => Token_Ptr); - Set_Modified_Project_Of (Declarations, To => Extends); + Set_Extended_Project_Of (Declarations, To => Extends); Set_Project_Declaration_Of (Current_Project, Declarations); Parse_Declarative_Items (Declarations => First_Declarative_Item, @@ -115,7 +118,9 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) is - Current_Attribute : Attribute_Node_Id := First_Attribute; + Current_Attribute : Attribute_Node_Id := First_Attribute; + Full_Associative_Array : Boolean := False; + Attribute_Name : Name_Id := No_Name; begin Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration); @@ -125,12 +130,22 @@ package body Prj.Dect is Scan; + -- Body may be an attribute name + + if Token = Tok_Body then + Token := Tok_Identifier; + Token_Name := Snames.Name_Body; + end if; + Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then + Attribute_Name := Token_Name; Set_Name_Of (Attribute, To => Token_Name); Set_Location_Of (Attribute, To => Token_Ptr); + -- Find the attribute + while Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Name /= Token_Name @@ -138,22 +153,81 @@ package body Prj.Dect is Current_Attribute := Attributes.Table (Current_Attribute).Next; end loop; + -- If not a valid attribute name, issue an error, or a warning + -- if inside a package that does not need to be checked. + if Current_Attribute = Empty_Attribute then - Error_Msg ("undefined attribute """ & - Get_Name_String (Name_Of (Attribute)) & - """", - Token_Ptr); + declare + Message : constant String := + "undefined attribute """ & + Get_Name_String (Name_Of (Attribute)) & '"'; + + Warning : Boolean := + Current_Package /= Empty_Node + and then Current_Packages_To_Check /= All_Packages; + + begin + if Warning then + + -- Check that we are not in a package to check + + Get_Name_String (Name_Of (Current_Package)); + + for Index in Current_Packages_To_Check'Range loop + if Name_Buffer (1 .. Name_Len) = + Current_Packages_To_Check (Index).all + then + Warning := False; + exit; + end if; + end loop; + end if; + + if Warning then + Error_Msg ('?' & Message, Token_Ptr); + + else + Error_Msg (Message, Token_Ptr); + end if; + end; + + -- Set, if appropriate the index case insensitivity flag elsif Attributes.Table (Current_Attribute).Kind_2 = - Case_Insensitive_Associative_Array + Case_Insensitive_Associative_Array then Set_Case_Insensitive (Attribute, To => True); end if; - Scan; + Scan; -- past the attribute name end if; + -- Change obsolete names of attributes to the new names + + case Name_Of (Attribute) is + when Snames.Name_Specification => + Set_Name_Of (Attribute, To => Snames.Name_Spec); + + when Snames.Name_Specification_Suffix => + Set_Name_Of (Attribute, To => Snames.Name_Spec_Suffix); + + when Snames.Name_Implementation => + Set_Name_Of (Attribute, To => Snames.Name_Body); + + when Snames.Name_Implementation_Suffix => + Set_Name_Of (Attribute, To => Snames.Name_Body_Suffix); + + when others => + null; + end case; + + -- Associative array attributes + if Token = Tok_Left_Paren then + + -- If the attribute is not an associative array attribute, report + -- an error. + if Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Kind_2 = Single then @@ -164,69 +238,235 @@ package body Prj.Dect is Location_Of (Attribute)); end if; - Scan; + Scan; -- past the left parenthesis Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then - Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node)); - Scan; + Set_Associative_Array_Index_Of (Attribute, Token_Name); + Scan; -- past the literal string index end if; - Expect (Tok_Right_Paren, ")"); + Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then - Scan; + Scan; -- past the right parenthesis end if; else + -- If it is an associative array attribute and there are no left + -- parenthesis, then this is a full associative array declaration. + -- Flag it as such for later processing of its value. + if Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Kind_2 /= Single then - Error_Msg ("the attribute """ & - Get_Name_String - (Attributes.Table (Current_Attribute).Name) & - """ needs to be an associative array", - Location_Of (Attribute)); + Full_Associative_Array := True; end if; end if; + -- Set the expression kind of the attribute + if Current_Attribute /= Empty_Attribute then Set_Expression_Kind_Of (Attribute, To => Attributes.Table (Current_Attribute).Kind_1); end if; - Expect (Tok_Use, "use"); + Expect (Tok_Use, "USE"); if Token = Tok_Use then Scan; - declare - Expression_Location : constant Source_Ptr := Token_Ptr; - Expression : Project_Node_Id := Empty_Node; + if Full_Associative_Array then - begin - Parse_Expression - (Expression => Expression, - Current_Project => Current_Project, - Current_Package => Current_Package); - Set_Expression_Of (Attribute, To => Expression); - - if Current_Attribute /= Empty_Attribute - and then Expression /= Empty_Node - and then Attributes.Table (Current_Attribute).Kind_1 /= - Expression_Kind_Of (Expression) - then - Error_Msg - ("wrong expression kind for attribute """ & - Get_Name_String - (Attributes.Table (Current_Attribute).Name) & - """", - Expression_Location); - end if; - end; + -- Expect <project>'<same_attribute_name>, or + -- <project>.<same_package_name>'<same_attribute_name> + + declare + The_Project : Project_Node_Id := Empty_Node; + -- The node of the project where the associative array is + -- declared. + + The_Package : Project_Node_Id := Empty_Node; + -- The node of the package where the associative array is + -- declared, if any. + + Project_Name : Name_Id := No_Name; + -- The name of the project where the associative array is + -- declared. + + Location : Source_Ptr := No_Location; + -- The location of the project name + + begin + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Location := Token_Ptr; + + -- Find the project node in the imported project or + -- in the project being extended. + + The_Project := Imported_Or_Extended_Project_Of + (Current_Project, Token_Name); + + if The_Project = Empty_Node then + Error_Msg ("unknown project", Location); + Scan; -- past the project name + + else + Project_Name := Token_Name; + Scan; -- past the project name + + -- If this is inside a package, a dot followed by the + -- name of the package must followed the project name. + + if Current_Package /= Empty_Node then + Expect (Tok_Dot, "`.`"); + + if Token /= Tok_Dot then + The_Project := Empty_Node; + + else + Scan; -- past the dot + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + The_Project := Empty_Node; + + -- If it is not the same package name, issue error + + elsif Token_Name /= Name_Of (Current_Package) then + The_Project := Empty_Node; + Error_Msg + ("not the same package as " & + Get_Name_String (Name_Of (Current_Package)), + Token_Ptr); + + else + The_Package := First_Package_Of (The_Project); + + -- Look for the package node + + while The_Package /= Empty_Node + and then Name_Of (The_Package) /= Token_Name + loop + The_Package := + Next_Package_In_Project (The_Package); + end loop; + + -- If the package cannot be found in the + -- project, issue an error. + + if The_Package = Empty_Node then + The_Project := Empty_Node; + Error_Msg_Name_2 := Project_Name; + Error_Msg_Name_1 := Token_Name; + Error_Msg + ("package % not declared in project %", + Token_Ptr); + end if; + + Scan; -- past the package name + end if; + end if; + end if; + end if; + end if; + + if The_Project /= Empty_Node then + + -- Looking for '<same attribute name> + + Expect (Tok_Apostrophe, "`''`"); + + if Token /= Tok_Apostrophe then + The_Project := Empty_Node; + + else + Scan; -- past the apostrophe + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + The_Project := Empty_Node; + + else + -- If it is not the same attribute name, issue error + + if Token_Name /= Attribute_Name then + The_Project := Empty_Node; + Error_Msg_Name_1 := Attribute_Name; + Error_Msg ("invalid name, should be %", Token_Ptr); + end if; + + Scan; -- past the attribute name + end if; + end if; + end if; + + if The_Project = Empty_Node then + + -- If there were any problem, set the attribute id to null, + -- so that the node will not be recorded. + + Current_Attribute := Empty_Attribute; + + else + -- Set the appropriate field in the node. + -- Note that the index and the expression are nil. This + -- characterizes full associative array attribute + -- declarations. + + Set_Associative_Project_Of (Attribute, The_Project); + Set_Associative_Package_Of (Attribute, The_Package); + end if; + end; + + -- Other attribute declarations (not full associative array) + + else + declare + Expression_Location : constant Source_Ptr := Token_Ptr; + -- The location of the first token of the expression + + Expression : Project_Node_Id := Empty_Node; + -- The expression, value for the attribute declaration + + begin + -- Get the expression value and set it in the attribute node + + Parse_Expression + (Expression => Expression, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Expression_Of (Attribute, To => Expression); + + -- If the expression is legal, but not of the right kind + -- for the attribute, issue an error. + + if Current_Attribute /= Empty_Attribute + and then Expression /= Empty_Node + and then Attributes.Table (Current_Attribute).Kind_1 /= + Expression_Kind_Of (Expression) + then + Error_Msg + ("wrong expression kind for attribute """ & + Get_Name_String + (Attributes.Table (Current_Attribute).Name) & + """", + Expression_Location); + end if; + end; + end if; end if; + -- If the attribute was not recognized, return an empty node. + -- It may be that it is not in a package to check, and the node will + -- not be added to the tree. + + if Current_Attribute = Empty_Attribute then + Attribute := Empty_Node; + end if; end Parse_Attribute_Declaration; ----------------------------- @@ -292,7 +532,7 @@ package body Prj.Dect is end if; end if; - Expect (Tok_Is, "is"); + Expect (Tok_Is, "IS"); if Token = Tok_Is then @@ -330,7 +570,7 @@ package body Prj.Dect is Scan; - Expect (Tok_Arrow, "=>"); + Expect (Tok_Arrow, "`=>`"); -- Empty_Node in Field1 of a Case_Item indicates -- the "when others =>" branch. @@ -355,7 +595,7 @@ package body Prj.Dect is Parse_Choice_List (First_Choice => First_Choice); Set_First_Choice_Of (Current_Item, To => First_Choice); - Expect (Tok_Arrow, "=>"); + Expect (Tok_Arrow, "`=>`"); Parse_Declarative_Items (Declarations => First_Declarative_Item, @@ -372,7 +612,7 @@ package body Prj.Dect is End_Case_Construction; - Expect (Tok_End, "end case"); + Expect (Tok_End, "`END CASE`"); if Token = Tok_End then @@ -380,7 +620,7 @@ package body Prj.Dect is Scan; - Expect (Tok_Case, "case"); + Expect (Tok_Case, "CASE"); end if; @@ -388,7 +628,7 @@ package body Prj.Dect is Scan; - Expect (Tok_Semicolon, ";"); + Expect (Tok_Semicolon, "`;`"); end Parse_Case_Construction; @@ -486,24 +726,29 @@ package body Prj.Dect is end case; - Expect (Tok_Semicolon, "; after declarative items"); + Expect (Tok_Semicolon, "`;` after declarative items"); - if Current_Declarative_Item = Empty_Node then - Current_Declarative_Item := - Default_Project_Node (Of_Kind => N_Declarative_Item); - Declarations := Current_Declarative_Item; + -- Insert an N_Declarative_Item in the tree, but only if + -- Current_Declaration is not an empty node. - else - Next_Declarative_Item := - Default_Project_Node (Of_Kind => N_Declarative_Item); - Set_Next_Declarative_Item - (Current_Declarative_Item, To => Next_Declarative_Item); - Current_Declarative_Item := Next_Declarative_Item; - end if; + if Current_Declaration /= Empty_Node then + if Current_Declarative_Item = Empty_Node then + Current_Declarative_Item := + Default_Project_Node (Of_Kind => N_Declarative_Item); + Declarations := Current_Declarative_Item; + + else + Next_Declarative_Item := + Default_Project_Node (Of_Kind => N_Declarative_Item); + Set_Next_Declarative_Item + (Current_Declarative_Item, To => Next_Declarative_Item); + Current_Declarative_Item := Next_Declarative_Item; + end if; - Set_Current_Item_Node - (Current_Declarative_Item, To => Current_Declaration); - Set_Location_Of (Current_Declarative_Item, To => Item_Location); + Set_Current_Item_Node + (Current_Declarative_Item, To => Current_Declaration); + Set_Location_Of (Current_Declarative_Item, To => Item_Location); + end if; end loop; @@ -546,11 +791,16 @@ package body Prj.Dect is end loop; if Current_Package = Empty_Package then - Error_Msg ("""" & + Error_Msg ("?""" & Get_Name_String (Name_Of (Package_Declaration)) & """ is not an allowed package name", Token_Ptr); + -- Set the package declaration to "ignored" so that it is not + -- processed by Prj.Proc.Process. + + Set_Expression_Kind_Of (Package_Declaration, Ignored); + else Set_Package_Id_Of (Package_Declaration, To => Current_Package); @@ -598,22 +848,37 @@ package body Prj.Dect is if Token = Tok_Identifier then declare - Project_Name : Name_Id := Token_Name; + Project_Name : constant Name_Id := Token_Name; Clause : Project_Node_Id := First_With_Clause_Of (Current_Project); The_Project : Project_Node_Id := Empty_Node; - + Extended : constant Project_Node_Id := + Extended_Project_Of + (Project_Declaration_Of (Current_Project)); begin while Clause /= Empty_Node loop - The_Project := Project_Node_Of (Clause); - exit when Name_Of (The_Project) = Project_Name; + -- Only non limited imported projects may be used + -- in a renames declaration. + + The_Project := Non_Limited_Project_Node_Of (Clause); + exit when The_Project /= Empty_Node + and then Name_Of (The_Project) = Project_Name; Clause := Next_With_Clause_Of (Clause); end loop; if Clause = Empty_Node then - Error_Msg ("""" & - Get_Name_String (Project_Name) & - """ is not an imported project", Token_Ptr); + -- As we have not found the project in the imports, we check + -- if it's the name of an eventual extended project. + + if Extended /= Empty_Node + and then Name_Of (Extended) = Project_Name then + Set_Project_Of_Renamed_Package_Of + (Package_Declaration, To => Extended); + else + Error_Msg_Name_1 := Project_Name; + Error_Msg + ("% is not an imported or extended project", Token_Ptr); + end if; else Set_Project_Of_Renamed_Package_Of (Package_Declaration, To => The_Project); @@ -621,7 +886,7 @@ package body Prj.Dect is end; Scan; - Expect (Tok_Dot, "."); + Expect (Tok_Dot, "`.`"); if Token = Tok_Dot then Scan; @@ -662,7 +927,7 @@ package body Prj.Dect is end if; end if; - Expect (Tok_Semicolon, ";"); + Expect (Tok_Semicolon, "`;`"); elsif Token = Tok_Is then @@ -676,7 +941,7 @@ package body Prj.Dect is Set_First_Declarative_Item_Of (Package_Declaration, To => First_Declarative_Item); - Expect (Tok_End, "end"); + Expect (Tok_End, "END"); if Token = Tok_End then @@ -704,10 +969,10 @@ package body Prj.Dect is Scan; end if; - Expect (Tok_Semicolon, ";"); + Expect (Tok_Semicolon, "`;`"); else - Error_Msg ("expected ""is"" or ""renames""", Token_Ptr); + Error_Msg ("expected IS or RENAMES", Token_Ptr); end if; end Parse_Package_Declaration; @@ -775,13 +1040,13 @@ package body Prj.Dect is Scan; end if; - Expect (Tok_Is, "is"); + Expect (Tok_Is, "IS"); if Token = Tok_Is then Scan; end if; - Expect (Tok_Left_Paren, "("); + Expect (Tok_Left_Paren, "`(`"); if Token = Tok_Left_Paren then Scan; @@ -790,7 +1055,7 @@ package body Prj.Dect is Parse_String_Type_List (First_String => First_String); Set_First_Literal_String (String_Type, To => First_String); - Expect (Tok_Right_Paren, ")"); + Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan; @@ -814,6 +1079,7 @@ package body Prj.Dect is Project_Location : Source_Ptr := No_Location; Expression : Project_Node_Id := Empty_Node; Variable_Name : constant Name_Id := Token_Name; + OK : Boolean := True; begin Variable := @@ -833,7 +1099,9 @@ package body Prj.Dect is Set_Kind_Of (Variable, N_Typed_Variable_Declaration); Expect (Tok_Identifier, "identifier"); - if Token = Tok_Identifier then + OK := Token = Tok_Identifier; + + if OK then String_Type_Name := Token_Name; Type_Location := Token_Ptr; Scan; @@ -852,11 +1120,11 @@ package body Prj.Dect is Type_Location := Token_Ptr; Scan; else - String_Type_Name := No_Name; + OK := False; end if; end if; - if String_Type_Name /= No_Name then + if OK then declare Current : Project_Node_Id := First_String_Type_Of (Current_Project); @@ -900,6 +1168,7 @@ package body Prj.Dect is Get_Name_String (String_Type_Name) & """", Type_Location); + OK := False; else Set_String_Type_Of (Variable, To => Current); @@ -909,7 +1178,9 @@ package body Prj.Dect is end if; end if; - Expect (Tok_Colon_Equal, ":="); + Expect (Tok_Colon_Equal, "`:=`"); + + OK := OK and (Token = Tok_Colon_Equal); if Token = Tok_Colon_Equal then Scan; @@ -926,57 +1197,68 @@ package body Prj.Dect is Set_Expression_Of (Variable, To => Expression); if Expression /= Empty_Node then + -- A typed string must have a single string value, not a list + + if Kind_Of (Variable) = N_Typed_Variable_Declaration + and then Expression_Kind_Of (Expression) = List + then + Error_Msg + ("expression must be a single string", Expression_Location); + end if; + Set_Expression_Kind_Of (Variable, To => Expression_Kind_Of (Expression)); end if; - declare - The_Variable : Project_Node_Id := Empty_Node; - - begin - if Current_Package /= Empty_Node then - The_Variable := First_Variable_Of (Current_Package); - elsif Current_Project /= Empty_Node then - The_Variable := First_Variable_Of (Current_Project); - end if; - - while The_Variable /= Empty_Node - and then Name_Of (The_Variable) /= Variable_Name - loop - The_Variable := Next_Variable (The_Variable); - end loop; + if OK then + declare + The_Variable : Project_Node_Id := Empty_Node; - if The_Variable = Empty_Node then + begin if Current_Package /= Empty_Node then - Set_Next_Variable - (Variable, To => First_Variable_Of (Current_Package)); - Set_First_Variable_Of (Current_Package, To => Variable); - + The_Variable := First_Variable_Of (Current_Package); elsif Current_Project /= Empty_Node then - Set_Next_Variable - (Variable, To => First_Variable_Of (Current_Project)); - Set_First_Variable_Of (Current_Project, To => Variable); + The_Variable := First_Variable_Of (Current_Project); end if; - else - if Expression_Kind_Of (Variable) /= Undefined then - if Expression_Kind_Of (The_Variable) = Undefined then - Set_Expression_Kind_Of - (The_Variable, To => Expression_Kind_Of (Variable)); + while The_Variable /= Empty_Node + and then Name_Of (The_Variable) /= Variable_Name + loop + The_Variable := Next_Variable (The_Variable); + end loop; - else - if Expression_Kind_Of (The_Variable) /= - Expression_Kind_Of (Variable) - then - Error_Msg ("wrong expression kind for variable """ & - Get_Name_String (Name_Of (The_Variable)) & - """", - Expression_Location); + if The_Variable = Empty_Node then + if Current_Package /= Empty_Node then + Set_Next_Variable + (Variable, To => First_Variable_Of (Current_Package)); + Set_First_Variable_Of (Current_Package, To => Variable); + + elsif Current_Project /= Empty_Node then + Set_Next_Variable + (Variable, To => First_Variable_Of (Current_Project)); + Set_First_Variable_Of (Current_Project, To => Variable); + end if; + + else + if Expression_Kind_Of (Variable) /= Undefined then + if Expression_Kind_Of (The_Variable) = Undefined then + Set_Expression_Kind_Of + (The_Variable, To => Expression_Kind_Of (Variable)); + + else + if Expression_Kind_Of (The_Variable) /= + Expression_Kind_Of (Variable) + then + Error_Msg ("wrong expression kind for variable """ & + Get_Name_String (Name_Of (The_Variable)) & + """", + Expression_Location); + end if; end if; end if; end if; - end if; - end; + end; + end if; end Parse_Variable_Declaration; |