diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/prj-dect.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/prj-dect.adb | 1452 |
1 files changed, 1452 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/prj-dect.adb b/gcc-4.2.1/gcc/ada/prj-dect.adb new file mode 100644 index 000000000..162db1348 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/prj-dect.adb @@ -0,0 +1,1452 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . D E C T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2005, 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Namet; use Namet; +with Opt; use Opt; +with Prj.Err; use Prj.Err; +with Prj.Strt; use Prj.Strt; +with Prj.Tree; use Prj.Tree; +with Snames; +with Prj.Attr; use Prj.Attr; +with Prj.Attr.PM; use Prj.Attr.PM; +with Uintp; use Uintp; + +package body Prj.Dect is + + type Zone is (In_Project, In_Package, In_Case_Construction); + -- 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 + (In_Tree : Project_Node_Tree_Ref; + Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access); + -- Parse an attribute declaration + + procedure Parse_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access); + -- Parse a case construction + + procedure Parse_Declarative_Items + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access); + -- Parse declarative items. Depending on In_Zone, some declarative + -- items may be forbiden. + + procedure Parse_Package_Declaration + (In_Tree : Project_Node_Tree_Ref; + Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id; + Packages_To_Check : String_List_Access); + -- Parse a package declaration + + procedure Parse_String_Type_Declaration + (In_Tree : Project_Node_Tree_Ref; + String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id); + -- 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); + -- Parse a variable assignment + -- <variable_Name> := <expression>; OR + -- <variable_Name> : <string_type_Name> := <string_expression>; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + Current_Project : Project_Node_Id; + Extends : Project_Node_Id; + Packages_To_Check : String_List_Access) + is + First_Declarative_Item : Project_Node_Id := Empty_Node; + + begin + Declarations := + Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => In_Tree); + Set_Location_Of (Declarations, In_Tree, To => Token_Ptr); + Set_Extended_Project_Of (Declarations, In_Tree, To => Extends); + Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations); + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Tree => In_Tree, + In_Zone => In_Project, + First_Attribute => Prj.Attr.Attribute_First, + Current_Project => Current_Project, + Current_Package => Empty_Node, + Packages_To_Check => Packages_To_Check); + Set_First_Declarative_Item_Of + (Declarations, In_Tree, To => First_Declarative_Item); + end Parse; + + --------------------------------- + -- Parse_Attribute_Declaration -- + --------------------------------- + + procedure Parse_Attribute_Declaration + (In_Tree : Project_Node_Tree_Ref; + Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access) + is + Current_Attribute : Attribute_Node_Id := First_Attribute; + Full_Associative_Array : Boolean := False; + Attribute_Name : Name_Id := No_Name; + Optional_Index : Boolean := False; + Pkg_Id : Package_Node_Id := Empty_Package; + Warning : Boolean := False; + + begin + Attribute := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); + Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); + Set_Previous_Line_Node (Attribute); + + -- Scan past "for" + + Scan (In_Tree); + + -- 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, In_Tree, To => Token_Name); + Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); + + -- Find the attribute + + Current_Attribute := + Attribute_Node_Id_Of (Token_Name, First_Attribute); + + -- If the attribute cannot be found, create the attribute if inside + -- an unknown package. + + if Current_Attribute = Empty_Attribute then + if Current_Package /= Empty_Node + and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored + then + Pkg_Id := Package_Id_Of (Current_Package, In_Tree); + Add_Attribute (Pkg_Id, Token_Name, Current_Attribute); + Error_Msg_Name_1 := Token_Name; + Error_Msg ("?unknown attribute {", Token_Ptr); + + else + -- If not a valid attribute name, issue an error, or a warning + -- if inside a package that does not need to be checked. + + Warning := Current_Package /= Empty_Node and then + Packages_To_Check /= All_Packages; + + if Warning then + + -- Check that we are not in a package to check + + Get_Name_String (Name_Of (Current_Package, In_Tree)); + + for Index in Packages_To_Check'Range loop + if Name_Buffer (1 .. Name_Len) = + Packages_To_Check (Index).all + then + Warning := False; + exit; + end if; + end loop; + end if; + + Error_Msg_Name_1 := Token_Name; + Error_Msg_Warn := Warning; + Error_Msg ("<undefined attribute {", Token_Ptr); + end if; + + -- Set, if appropriate the index case insensitivity flag + + elsif Attribute_Kind_Of (Current_Attribute) in + Case_Insensitive_Associative_Array .. + Optional_Index_Case_Insensitive_Associative_Array + then + Set_Case_Insensitive (Attribute, In_Tree, To => True); + end if; + + Scan (In_Tree); -- past the attribute name + end if; + + -- Change obsolete names of attributes to the new names + + if Current_Package /= Empty_Node + and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored + then + case Name_Of (Attribute, In_Tree) is + when Snames.Name_Specification => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); + + when Snames.Name_Specification_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); + + when Snames.Name_Implementation => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); + + when Snames.Name_Implementation_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); + + when others => + null; + end case; + end if; + + -- Associative array attributes + + if Token = Tok_Left_Paren then + + -- If the attribute is not an associative array attribute, report + -- an error. If this information is still unknown, set the kind + -- to Associative_Array. + + if Current_Attribute /= Empty_Attribute + and then Attribute_Kind_Of (Current_Attribute) = Single + then + Error_Msg ("the attribute """ & + Get_Name_String + (Attribute_Name_Of (Current_Attribute)) & + """ cannot be an associative array", + Location_Of (Attribute, In_Tree)); + + elsif Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); + end if; + + Scan (In_Tree); -- past the left parenthesis + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Associative_Array_Index_Of (Attribute, In_Tree, Token_Name); + Scan (In_Tree); -- past the literal string index + + if Token = Tok_At then + case Attribute_Kind_Of (Current_Attribute) is + when Optional_Index_Associative_Array | + Optional_Index_Case_Insensitive_Associative_Array => + Scan (In_Tree); + Expect (Tok_Integer_Literal, "integer literal"); + + if Token = Tok_Integer_Literal then + + -- Set the source index value from given literal + + declare + Index : constant Int := + UI_To_Int (Int_Literal_Value); + begin + if Index = 0 then + Error_Msg ("index cannot be zero", Token_Ptr); + else + Set_Source_Index_Of + (Attribute, In_Tree, To => Index); + end if; + end; + + Scan (In_Tree); + end if; + + when others => + Error_Msg ("index not allowed here", Token_Ptr); + Scan (In_Tree); + + if Token = Tok_Integer_Literal then + Scan (In_Tree); + end if; + end case; + end if; + end if; + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); -- 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 + Attribute_Kind_Of (Current_Attribute) /= Single + then + if Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Single); + + else + Full_Associative_Array := True; + end if; + end if; + end if; + + -- Set the expression kind of the attribute + + if Current_Attribute /= Empty_Attribute then + Set_Expression_Kind_Of + (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); + Optional_Index := Optional_Index_Of (Current_Attribute); + end if; + + Expect (Tok_Use, "USE"); + + if Token = Tok_Use then + Scan (In_Tree); + + if Full_Associative_Array then + + -- 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, In_Tree, Token_Name); + + if The_Project = Empty_Node then + Error_Msg ("unknown project", Location); + Scan (In_Tree); -- past the project name + + else + Project_Name := Token_Name; + Scan (In_Tree); -- 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 (In_Tree); -- 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, In_Tree) + then + The_Project := Empty_Node; + Error_Msg + ("not the same package as " & + Get_Name_String + (Name_Of (Current_Package, In_Tree)), + Token_Ptr); + + else + The_Package := + First_Package_Of (The_Project, In_Tree); + + -- Look for the package node + + while The_Package /= Empty_Node + and then + Name_Of (The_Package, In_Tree) /= Token_Name + loop + The_Package := + Next_Package_In_Project + (The_Package, In_Tree); + 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 (In_Tree); -- 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 (In_Tree); -- 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 (In_Tree); -- 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, In_Tree, The_Project); + Set_Associative_Package_Of (Attribute, In_Tree, 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 + (In_Tree => In_Tree, + Expression => Expression, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => Optional_Index); + Set_Expression_Of (Attribute, In_Tree, 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 Variable_Kind_Of (Current_Attribute) /= + Expression_Kind_Of (Expression, In_Tree) + then + if Variable_Kind_Of (Current_Attribute) = Undefined then + Set_Variable_Kind_Of + (Current_Attribute, + To => Expression_Kind_Of (Expression, In_Tree)); + + else + Error_Msg + ("wrong expression kind for attribute """ & + Get_Name_String + (Attribute_Name_Of (Current_Attribute)) & + """", + Expression_Location); + end if; + 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; + + Set_End_Of_Line (Attribute); + Set_Previous_Line_Node (Attribute); + end Parse_Attribute_Declaration; + + ----------------------------- + -- Parse_Case_Construction -- + ----------------------------- + + procedure Parse_Case_Construction + (In_Tree : Project_Node_Tree_Ref; + Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access) + is + Current_Item : Project_Node_Id := Empty_Node; + Next_Item : Project_Node_Id := Empty_Node; + First_Case_Item : Boolean := True; + + Variable_Location : Source_Ptr := No_Location; + + String_Type : Project_Node_Id := Empty_Node; + + Case_Variable : Project_Node_Id := Empty_Node; + + First_Declarative_Item : Project_Node_Id := Empty_Node; + + First_Choice : Project_Node_Id := Empty_Node; + + When_Others : Boolean := False; + -- Set to True when there is a "when others =>" clause + + begin + Case_Construction := + Default_Project_Node + (Of_Kind => N_Case_Construction, In_Tree => In_Tree); + Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr); + + -- Scan past "case" + + Scan (In_Tree); + + -- Get the switch variable + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Variable_Location := Token_Ptr; + Parse_Variable_Reference + (In_Tree => In_Tree, + Variable => Case_Variable, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Case_Variable_Reference_Of + (Case_Construction, In_Tree, To => Case_Variable); + + else + if Token /= Tok_Is then + Scan (In_Tree); + end if; + end if; + + if Case_Variable /= Empty_Node then + String_Type := String_Type_Of (Case_Variable, In_Tree); + + if String_Type = Empty_Node then + Error_Msg ("variable """ & + Get_Name_String (Name_Of (Case_Variable, In_Tree)) & + """ is not typed", + Variable_Location); + end if; + end if; + + Expect (Tok_Is, "IS"); + + if Token = Tok_Is then + Set_End_Of_Line (Case_Construction); + Set_Previous_Line_Node (Case_Construction); + Set_Next_End_Node (Case_Construction); + + -- Scan past "is" + + Scan (In_Tree); + end if; + + Start_New_Case_Construction (In_Tree, String_Type); + + When_Loop : + + while Token = Tok_When loop + + if First_Case_Item then + Current_Item := + Default_Project_Node + (Of_Kind => N_Case_Item, In_Tree => In_Tree); + Set_First_Case_Item_Of + (Case_Construction, In_Tree, To => Current_Item); + First_Case_Item := False; + + else + Next_Item := + Default_Project_Node + (Of_Kind => N_Case_Item, In_Tree => In_Tree); + Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item); + Current_Item := Next_Item; + end if; + + Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr); + + -- Scan past "when" + + Scan (In_Tree); + + if Token = Tok_Others then + When_Others := True; + + -- Scan past "others" + + Scan (In_Tree); + + Expect (Tok_Arrow, "`=>`"); + Set_End_Of_Line (Current_Item); + Set_Previous_Line_Node (Current_Item); + + -- Empty_Node in Field1 of a Case_Item indicates + -- the "when others =>" branch. + + Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check); + + -- "when others =>" must be the last branch, so save the + -- Case_Item and exit + + Set_First_Declarative_Item_Of + (Current_Item, In_Tree, To => First_Declarative_Item); + exit When_Loop; + + else + Parse_Choice_List + (In_Tree => In_Tree, + First_Choice => First_Choice); + Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); + + Expect (Tok_Arrow, "`=>`"); + Set_End_Of_Line (Current_Item); + Set_Previous_Line_Node (Current_Item); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check); + + Set_First_Declarative_Item_Of + (Current_Item, In_Tree, To => First_Declarative_Item); + + end if; + end loop When_Loop; + + End_Case_Construction + (Check_All_Labels => not When_Others and not Quiet_Output, + Case_Location => Location_Of (Case_Construction, In_Tree)); + + Expect (Tok_End, "`END CASE`"); + Remove_Next_End_Node; + + if Token = Tok_End then + + -- Scan past "end" + + Scan (In_Tree); + + Expect (Tok_Case, "CASE"); + + end if; + + -- Scan past "case" + + Scan (In_Tree); + + Expect (Tok_Semicolon, "`;`"); + Set_Previous_End_Node (Case_Construction); + + end Parse_Case_Construction; + + ----------------------------- + -- Parse_Declarative_Items -- + ----------------------------- + + procedure Parse_Declarative_Items + (In_Tree : Project_Node_Tree_Ref; + Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id; + Packages_To_Check : String_List_Access) + is + Current_Declarative_Item : Project_Node_Id := Empty_Node; + Next_Declarative_Item : Project_Node_Id := Empty_Node; + Current_Declaration : Project_Node_Id := Empty_Node; + Item_Location : Source_Ptr := No_Location; + + begin + Declarations := Empty_Node; + + loop + -- We are always positioned at the token that precedes + -- the first token of the declarative element. + -- Scan past it + + Scan (In_Tree); + + Item_Location := Token_Ptr; + + case Token is + when Tok_Identifier => + + if In_Zone = In_Case_Construction then + Error_Msg ("a variable cannot be declared here", + Token_Ptr); + end if; + + Parse_Variable_Declaration + (In_Tree, + Current_Declaration, + Current_Project => Current_Project, + Current_Package => Current_Package); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_For => + + Parse_Attribute_Declaration + (In_Tree => In_Tree, + Attribute => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_Null => + + Scan (In_Tree); -- past "null" + + when Tok_Package => + + -- Package declaration + + if In_Zone /= In_Project then + Error_Msg ("a package cannot be declared here", Token_Ptr); + end if; + + Parse_Package_Declaration + (In_Tree => In_Tree, + Package_Declaration => Current_Declaration, + Current_Project => Current_Project, + Packages_To_Check => Packages_To_Check); + + Set_Previous_End_Node (Current_Declaration); + + when Tok_Type => + + -- Type String Declaration + + if In_Zone /= In_Project then + Error_Msg ("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); + + Set_End_Of_Line (Current_Declaration); + Set_Previous_Line_Node (Current_Declaration); + + when Tok_Case => + + -- Case construction + + Parse_Case_Construction + (In_Tree => In_Tree, + Case_Construction => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package, + Packages_To_Check => Packages_To_Check); + + Set_Previous_End_Node (Current_Declaration); + + when others => + exit; + + -- We are leaving Parse_Declarative_Items positionned + -- at the first token after the list of declarative items. + -- It could be "end" (for a project, a package declaration or + -- a case construction) or "when" (for a case construction) + + end case; + + Expect (Tok_Semicolon, "`;` after declarative items"); + + -- Insert an N_Declarative_Item in the tree, but only if + -- Current_Declaration is not an empty node. + + if Current_Declaration /= Empty_Node then + if Current_Declarative_Item = Empty_Node then + Current_Declarative_Item := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); + Declarations := Current_Declarative_Item; + + else + Next_Declarative_Item := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); + Set_Next_Declarative_Item + (Current_Declarative_Item, In_Tree, + To => Next_Declarative_Item); + Current_Declarative_Item := Next_Declarative_Item; + end if; + + Set_Current_Item_Node + (Current_Declarative_Item, In_Tree, + To => Current_Declaration); + Set_Location_Of + (Current_Declarative_Item, In_Tree, To => Item_Location); + end if; + end loop; + end Parse_Declarative_Items; + + ------------------------------- + -- Parse_Package_Declaration -- + ------------------------------- + + procedure Parse_Package_Declaration + (In_Tree : Project_Node_Tree_Ref; + Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id; + Packages_To_Check : String_List_Access) + is + First_Attribute : Attribute_Node_Id := Empty_Attribute; + Current_Package : Package_Node_Id := Empty_Package; + First_Declarative_Item : Project_Node_Id := Empty_Node; + + begin + Package_Declaration := + Default_Project_Node + (Of_Kind => N_Package_Declaration, In_Tree => In_Tree); + Set_Location_Of (Package_Declaration, In_Tree, To => Token_Ptr); + + -- Scan past "package" + + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name); + + Current_Package := Package_Node_Id_Of (Token_Name); + + if Current_Package /= Empty_Package then + First_Attribute := First_Attribute_Of (Current_Package); + + else + Error_Msg ("?""" & + Get_Name_String + (Name_Of (Package_Declaration, In_Tree)) & + """ is not a known 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, In_Tree, Ignored); + + -- Add the unknown package in the list of packages + + Add_Unknown_Package (Token_Name, Current_Package); + end if; + + Set_Package_Id_Of + (Package_Declaration, In_Tree, To => Current_Package); + + declare + Current : Project_Node_Id := + First_Package_Of (Current_Project, In_Tree); + + begin + while Current /= Empty_Node + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_Package_In_Project (Current, In_Tree); + end loop; + + if Current /= Empty_Node then + Error_Msg + ("package """ & + Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & + """ is declared twice in the same project", + Token_Ptr); + + else + -- Add the package to the project list + + Set_Next_Package_In_Project + (Package_Declaration, In_Tree, + To => First_Package_Of (Current_Project, In_Tree)); + Set_First_Package_Of + (Current_Project, In_Tree, To => Package_Declaration); + end if; + end; + + -- Scan past the package name + + Scan (In_Tree); + end if; + + if Token = Tok_Renames then + + -- Scan past "renames" + + Scan (In_Tree); + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + declare + Project_Name : constant Name_Id := Token_Name; + Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project, In_Tree); + The_Project : Project_Node_Id := Empty_Node; + Extended : constant Project_Node_Id := + Extended_Project_Of + (Project_Declaration_Of + (Current_Project, In_Tree), + In_Tree); + begin + while Clause /= Empty_Node loop + -- Only non limited imported projects may be used in a + -- renames declaration. + + The_Project := + Non_Limited_Project_Node_Of (Clause, In_Tree); + exit when The_Project /= Empty_Node + and then Name_Of (The_Project, In_Tree) = Project_Name; + Clause := Next_With_Clause_Of (Clause, In_Tree); + end loop; + + if Clause = Empty_Node then + -- 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, In_Tree) = Project_Name + then + Set_Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree, 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, In_Tree, To => The_Project); + end if; + end; + + Scan (In_Tree); + Expect (Tok_Dot, "`.`"); + + if Token = Tok_Dot then + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + if Name_Of (Package_Declaration, In_Tree) /= Token_Name then + Error_Msg ("not the same package name", Token_Ptr); + elsif + Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree) /= Empty_Node + then + declare + Current : Project_Node_Id := + First_Package_Of + (Project_Of_Renamed_Package_Of + (Package_Declaration, In_Tree), + In_Tree); + + begin + while Current /= Empty_Node + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := + Next_Package_In_Project (Current, In_Tree); + end loop; + + if Current = Empty_Node then + Error_Msg + ("""" & + Get_Name_String (Token_Name) & + """ is not a package declared by the project", + Token_Ptr); + end if; + end; + end if; + + Scan (In_Tree); + end if; + end if; + end if; + + Expect (Tok_Semicolon, "`;`"); + Set_End_Of_Line (Package_Declaration); + Set_Previous_Line_Node (Package_Declaration); + + elsif Token = Tok_Is then + Set_End_Of_Line (Package_Declaration); + Set_Previous_Line_Node (Package_Declaration); + Set_Next_End_Node (Package_Declaration); + + Parse_Declarative_Items + (In_Tree => In_Tree, + Declarations => First_Declarative_Item, + In_Zone => In_Package, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Package_Declaration, + Packages_To_Check => Packages_To_Check); + + Set_First_Declarative_Item_Of + (Package_Declaration, In_Tree, To => First_Declarative_Item); + + Expect (Tok_End, "END"); + + if Token = Tok_End then + + -- Scan past "end" + + Scan (In_Tree); + end if; + + -- We should have the name of the package after "end" + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier + and then Name_Of (Package_Declaration, In_Tree) /= No_Name + 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); + end if; + + if Token /= Tok_Semicolon then + + -- Scan past the package name + + Scan (In_Tree); + end if; + + Expect (Tok_Semicolon, "`;`"); + Remove_Next_End_Node; + + else + Error_Msg ("expected IS or RENAMES", Token_Ptr); + end if; + + end Parse_Package_Declaration; + + ----------------------------------- + -- Parse_String_Type_Declaration -- + ----------------------------------- + + procedure Parse_String_Type_Declaration + (In_Tree : Project_Node_Tree_Ref; + String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id) + is + Current : Project_Node_Id := Empty_Node; + First_String : Project_Node_Id := Empty_Node; + + begin + String_Type := + Default_Project_Node + (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree); + + Set_Location_Of (String_Type, In_Tree, To => Token_Ptr); + + -- Scan past "type" + + Scan (In_Tree); + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (String_Type, In_Tree, To => Token_Name); + + Current := First_String_Type_Of (Current_Project, In_Tree); + while Current /= Empty_Node + and then + Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + + if Current /= Empty_Node then + Error_Msg ("duplicate string type name """ & + Get_Name_String (Token_Name) & + """", + Token_Ptr); + else + Current := First_Variable_Of (Current_Project, In_Tree); + while Current /= Empty_Node + and then Name_Of (Current, In_Tree) /= Token_Name + loop + Current := Next_Variable (Current, In_Tree); + end loop; + + if Current /= Empty_Node then + Error_Msg ("""" & + Get_Name_String (Token_Name) & + """ is already a variable name", Token_Ptr); + else + Set_Next_String_Type + (String_Type, In_Tree, + To => First_String_Type_Of (Current_Project, In_Tree)); + Set_First_String_Type_Of + (Current_Project, In_Tree, To => String_Type); + end if; + end if; + + -- Scan past the name + + Scan (In_Tree); + end if; + + Expect (Tok_Is, "IS"); + + if Token = Tok_Is then + Scan (In_Tree); + end if; + + Expect (Tok_Left_Paren, "`(`"); + + if Token = Tok_Left_Paren then + Scan (In_Tree); + end if; + + Parse_String_Type_List + (In_Tree => In_Tree, First_String => First_String); + Set_First_Literal_String (String_Type, In_Tree, To => First_String); + + Expect (Tok_Right_Paren, "`)`"); + + if Token = Tok_Right_Paren then + Scan (In_Tree); + end if; + + end Parse_String_Type_Declaration; + + -------------------------------- + -- Parse_Variable_Declaration -- + -------------------------------- + + 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) + is + Expression_Location : Source_Ptr; + String_Type_Name : Name_Id := No_Name; + Project_String_Type_Name : Name_Id := No_Name; + Type_Location : Source_Ptr := No_Location; + Project_Location : Source_Ptr := No_Location; + Expression : Project_Node_Id := Empty_Node; + Variable_Name : constant Name_Id := Token_Name; + OK : Boolean := True; + + begin + Variable := + Default_Project_Node + (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree); + Set_Name_Of (Variable, In_Tree, To => Variable_Name); + Set_Location_Of (Variable, In_Tree, To => Token_Ptr); + + -- Scan past the variable name + + Scan (In_Tree); + + if Token = Tok_Colon then + + -- Typed string variable declaration + + Scan (In_Tree); + Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration); + Expect (Tok_Identifier, "identifier"); + + OK := Token = Tok_Identifier; + + if OK then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan (In_Tree); + + if Token = Tok_Dot then + Project_String_Type_Name := String_Type_Name; + Project_Location := Type_Location; + + -- Scan past the dot + + Scan (In_Tree); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan (In_Tree); + else + OK := False; + end if; + end if; + + if OK then + declare + Current : Project_Node_Id := + First_String_Type_Of (Current_Project, In_Tree); + + begin + if Project_String_Type_Name /= No_Name then + declare + The_Project_Name_And_Node : constant + Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get + (In_Tree.Projects_HT, Project_String_Type_Name); + + use Tree_Private_Part; + + begin + if The_Project_Name_And_Node = + Tree_Private_Part.No_Project_Name_And_Node + then + Error_Msg ("unknown project """ & + Get_Name_String + (Project_String_Type_Name) & + """", + Project_Location); + Current := Empty_Node; + else + Current := + First_String_Type_Of + (The_Project_Name_And_Node.Node, In_Tree); + end if; + end; + end if; + + while Current /= Empty_Node + and then Name_Of (Current, In_Tree) /= String_Type_Name + loop + Current := Next_String_Type (Current, In_Tree); + end loop; + + if Current = Empty_Node then + Error_Msg ("unknown string type """ & + Get_Name_String (String_Type_Name) & + """", + Type_Location); + OK := False; + else + Set_String_Type_Of + (Variable, In_Tree, To => Current); + end if; + end; + end if; + end if; + end if; + + Expect (Tok_Colon_Equal, "`:=`"); + + OK := OK and (Token = Tok_Colon_Equal); + + if Token = Tok_Colon_Equal then + Scan (In_Tree); + end if; + + -- Get the single string or string list value + + Expression_Location := Token_Ptr; + + Parse_Expression + (In_Tree => In_Tree, + Expression => Expression, + Current_Project => Current_Project, + Current_Package => Current_Package, + Optional_Index => False); + Set_Expression_Of (Variable, In_Tree, To => Expression); + + if Expression /= Empty_Node then + -- A typed string must have a single string value, not a list + + if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration + and then Expression_Kind_Of (Expression, In_Tree) = List + then + Error_Msg + ("expression must be a single string", Expression_Location); + end if; + + Set_Expression_Kind_Of + (Variable, In_Tree, + To => Expression_Kind_Of (Expression, In_Tree)); + end if; + + if OK then + declare + The_Variable : Project_Node_Id := Empty_Node; + + begin + if Current_Package /= Empty_Node then + The_Variable := First_Variable_Of (Current_Package, In_Tree); + elsif Current_Project /= Empty_Node then + The_Variable := First_Variable_Of (Current_Project, In_Tree); + end if; + + while The_Variable /= Empty_Node + and then Name_Of (The_Variable, In_Tree) /= Variable_Name + loop + The_Variable := Next_Variable (The_Variable, In_Tree); + end loop; + + if The_Variable = Empty_Node then + if Current_Package /= Empty_Node then + Set_Next_Variable + (Variable, In_Tree, + To => First_Variable_Of (Current_Package, In_Tree)); + Set_First_Variable_Of + (Current_Package, In_Tree, To => Variable); + + elsif Current_Project /= Empty_Node then + Set_Next_Variable + (Variable, In_Tree, + To => First_Variable_Of (Current_Project, In_Tree)); + Set_First_Variable_Of + (Current_Project, In_Tree, To => Variable); + end if; + + else + if Expression_Kind_Of (Variable, In_Tree) /= Undefined then + if + Expression_Kind_Of (The_Variable, In_Tree) = Undefined + then + Set_Expression_Kind_Of + (The_Variable, In_Tree, + To => Expression_Kind_Of (Variable, In_Tree)); + + else + if Expression_Kind_Of (The_Variable, In_Tree) /= + Expression_Kind_Of (Variable, In_Tree) + then + Error_Msg ("wrong expression kind for variable """ & + Get_Name_String + (Name_Of (The_Variable, In_Tree)) & + """", + Expression_Location); + end if; + end if; + end if; + end if; + end; + end if; + + end Parse_Variable_Declaration; + +end Prj.Dect; |