------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . D E C T -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 2001-2002 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, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Errout; use Errout; with Namet; use Namet; with Prj.Strt; use Prj.Strt; with Prj.Tree; use Prj.Tree; with Scans; use Scans; with Sinfo; use Sinfo; 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 ??? procedure Parse_Attribute_Declaration (Attribute : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id); -- Parse an attribute declaration. procedure Parse_Case_Construction (Case_Construction : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id); -- Parse a case construction procedure Parse_Declarative_Items (Declarations : out Project_Node_Id; In_Zone : Zone; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id); -- Parse declarative items. Depending on In_Zone, some declarative -- items may be forbiden. procedure Parse_Package_Declaration (Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id); -- Parse a package declaration procedure Parse_String_Type_Declaration (String_Type : out Project_Node_Id; Current_Project : Project_Node_Id); -- type is ( { , } ) ; procedure Parse_Variable_Declaration (Variable : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id); -- Parse a variable assignment -- := ; OR -- : := ; ----------- -- Parse -- ----------- procedure Parse (Declarations : out Project_Node_Id; Current_Project : Project_Node_Id; Extends : Project_Node_Id) is First_Declarative_Item : Project_Node_Id := Empty_Node; 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_Project_Declaration_Of (Current_Project, Declarations); Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Zone => In_Project, First_Attribute => Prj.Attr.Attribute_First, Current_Project => Current_Project, Current_Package => Empty_Node); Set_First_Declarative_Item_Of (Declarations, To => First_Declarative_Item); end Parse; --------------------------------- -- Parse_Attribute_Declaration -- --------------------------------- procedure Parse_Attribute_Declaration (Attribute : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) is Current_Attribute : Attribute_Node_Id := First_Attribute; begin Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration); Set_Location_Of (Attribute, To => Token_Ptr); -- Scan past "for" Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (Attribute, To => Token_Name); Set_Location_Of (Attribute, To => Token_Ptr); while Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Name /= Token_Name loop Current_Attribute := Attributes.Table (Current_Attribute).Next; end loop; if Current_Attribute = Empty_Attribute then Error_Msg ("undefined attribute """ & Get_Name_String (Name_Of (Attribute)) & """", Token_Ptr); elsif Attributes.Table (Current_Attribute).Kind_2 = Case_Insensitive_Associative_Array then Set_Case_Insensitive (Attribute, To => True); end if; Scan; end if; if Token = Tok_Left_Paren then 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) & """ cannot be an associative array", Location_Of (Attribute)); end if; Scan; Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node)); Scan; end if; Expect (Tok_Right_Paren, ")"); if Token = Tok_Right_Paren then Scan; end if; else 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)); end if; end if; if Current_Attribute /= Empty_Attribute then Set_Expression_Kind_Of (Attribute, To => Attributes.Table (Current_Attribute).Kind_1); end if; Expect (Tok_Use, "use"); if Token = Tok_Use then Scan; declare Expression_Location : constant Source_Ptr := Token_Ptr; Expression : Project_Node_Id := Empty_Node; 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; end if; end Parse_Attribute_Declaration; ----------------------------- -- Parse_Case_Construction -- ----------------------------- procedure Parse_Case_Construction (Case_Construction : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) 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; begin Case_Construction := Default_Project_Node (Of_Kind => N_Case_Construction); Set_Location_Of (Case_Construction, To => Token_Ptr); -- Scan past "case" Scan; -- Get the switch variable Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Variable_Location := Token_Ptr; Parse_Variable_Reference (Variable => Case_Variable, Current_Project => Current_Project, Current_Package => Current_Package); Set_Case_Variable_Reference_Of (Case_Construction, To => Case_Variable); else if Token /= Tok_Is then Scan; end if; end if; if Case_Variable /= Empty_Node then String_Type := String_Type_Of (Case_Variable); if String_Type = Empty_Node then Error_Msg ("variable """ & Get_Name_String (Name_Of (Case_Variable)) & """ is not typed", Variable_Location); end if; end if; Expect (Tok_Is, "is"); if Token = Tok_Is then -- Scan past "is" Scan; end if; Start_New_Case_Construction (String_Type); When_Loop : while Token = Tok_When loop if First_Case_Item then Current_Item := Default_Project_Node (Of_Kind => N_Case_Item); Set_First_Case_Item_Of (Case_Construction, To => Current_Item); First_Case_Item := False; else Next_Item := Default_Project_Node (Of_Kind => N_Case_Item); Set_Next_Case_Item (Current_Item, To => Next_Item); Current_Item := Next_Item; end if; Set_Location_Of (Current_Item, To => Token_Ptr); -- Scan past "when" Scan; if Token = Tok_Others then -- Scan past "others" Scan; Expect (Tok_Arrow, "=>"); -- Empty_Node in Field1 of a Case_Item indicates -- the "when others =>" branch. Set_First_Choice_Of (Current_Item, To => Empty_Node); Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Zone => In_Case_Construction, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); -- "when others =>" must be the last branch, so save the -- Case_Item and exit Set_First_Declarative_Item_Of (Current_Item, To => First_Declarative_Item); exit When_Loop; else Parse_Choice_List (First_Choice => First_Choice); Set_First_Choice_Of (Current_Item, To => First_Choice); Expect (Tok_Arrow, "=>"); Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Zone => In_Case_Construction, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); Set_First_Declarative_Item_Of (Current_Item, To => First_Declarative_Item); end if; end loop When_Loop; End_Case_Construction; Expect (Tok_End, "end case"); if Token = Tok_End then -- Scan past "end" Scan; Expect (Tok_Case, "case"); end if; -- Scan past "case" Scan; Expect (Tok_Semicolon, ";"); end Parse_Case_Construction; ----------------------------- -- Parse_Declarative_Items -- ----------------------------- procedure Parse_Declarative_Items (Declarations : out Project_Node_Id; In_Zone : Zone; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) 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; 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 (Current_Declaration, Current_Project => Current_Project, Current_Package => Current_Package); when Tok_For => Parse_Attribute_Declaration (Attribute => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); 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 (Package_Declaration => Current_Declaration, Current_Project => Current_Project); 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 (String_Type => Current_Declaration, Current_Project => Current_Project); when Tok_Case => -- Case construction Parse_Case_Construction (Case_Construction => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); 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"); 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); end loop; end Parse_Declarative_Items; ------------------------------- -- Parse_Package_Declaration -- ------------------------------- procedure Parse_Package_Declaration (Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id) 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); Set_Location_Of (Package_Declaration, To => Token_Ptr); -- Scan past "package" Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (Package_Declaration, To => Token_Name); for Index in Package_Attributes.First .. Package_Attributes.Last loop if Token_Name = Package_Attributes.Table (Index).Name then First_Attribute := Package_Attributes.Table (Index).First_Attribute; Current_Package := Index; exit; end if; end loop; if Current_Package = Empty_Package then Error_Msg ("""" & Get_Name_String (Name_Of (Package_Declaration)) & """ is not an allowed package name", Token_Ptr); else Set_Package_Id_Of (Package_Declaration, To => Current_Package); declare Current : Project_Node_Id := First_Package_Of (Current_Project); begin while Current /= Empty_Node and then Name_Of (Current) /= Token_Name loop Current := Next_Package_In_Project (Current); end loop; if Current /= Empty_Node then Error_Msg ("package """ & Get_Name_String (Name_Of (Package_Declaration)) & """ is declared twice in the same project", Token_Ptr); else -- Add the package to the project list Set_Next_Package_In_Project (Package_Declaration, To => First_Package_Of (Current_Project)); Set_First_Package_Of (Current_Project, To => Package_Declaration); end if; end; end if; -- Scan past the package name Scan; end if; if Token = Tok_Renames then -- Scan past "renames" Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then declare Project_Name : Name_Id := Token_Name; Clause : Project_Node_Id := First_With_Clause_Of (Current_Project); The_Project : Project_Node_Id := Empty_Node; begin while Clause /= Empty_Node loop The_Project := Project_Node_Of (Clause); exit when 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); else Set_Project_Of_Renamed_Package_Of (Package_Declaration, To => The_Project); end if; end; Scan; Expect (Tok_Dot, "."); if Token = Tok_Dot then Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then if Name_Of (Package_Declaration) /= Token_Name then Error_Msg ("not the same package name", Token_Ptr); elsif Project_Of_Renamed_Package_Of (Package_Declaration) /= Empty_Node then declare Current : Project_Node_Id := First_Package_Of (Project_Of_Renamed_Package_Of (Package_Declaration)); begin while Current /= Empty_Node and then Name_Of (Current) /= Token_Name loop Current := Next_Package_In_Project (Current); 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; end if; end if; end if; Expect (Tok_Semicolon, ";"); elsif Token = Tok_Is then Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Zone => In_Package, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Package_Declaration); Set_First_Declarative_Item_Of (Package_Declaration, To => First_Declarative_Item); Expect (Tok_End, "end"); if Token = Tok_End then -- Scan past "end" Scan; 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) /= No_Name and then Token_Name /= Name_Of (Package_Declaration) then Error_Msg_Name_1 := Name_Of (Package_Declaration); Error_Msg ("expected {", Token_Ptr); end if; if Token /= Tok_Semicolon then -- Scan past the package name Scan; end if; Expect (Tok_Semicolon, ";"); else Error_Msg ("expected ""is"" or ""renames""", Token_Ptr); end if; end Parse_Package_Declaration; ----------------------------------- -- Parse_String_Type_Declaration -- ----------------------------------- procedure Parse_String_Type_Declaration (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); Set_Location_Of (String_Type, To => Token_Ptr); -- Scan past "type" Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (String_Type, To => Token_Name); Current := First_String_Type_Of (Current_Project); while Current /= Empty_Node and then Name_Of (Current) /= Token_Name loop Current := Next_String_Type (Current); 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); while Current /= Empty_Node and then Name_Of (Current) /= Token_Name loop Current := Next_Variable (Current); 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, To => First_String_Type_Of (Current_Project)); Set_First_String_Type_Of (Current_Project, To => String_Type); end if; end if; -- Scan past the name Scan; end if; Expect (Tok_Is, "is"); if Token = Tok_Is then Scan; end if; Expect (Tok_Left_Paren, "("); if Token = Tok_Left_Paren then Scan; end if; Parse_String_Type_List (First_String => First_String); Set_First_Literal_String (String_Type, To => First_String); Expect (Tok_Right_Paren, ")"); if Token = Tok_Right_Paren then Scan; end if; end Parse_String_Type_Declaration; -------------------------------- -- Parse_Variable_Declaration -- -------------------------------- procedure Parse_Variable_Declaration (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; begin Variable := Default_Project_Node (Of_Kind => N_Variable_Declaration); Set_Name_Of (Variable, To => Variable_Name); Set_Location_Of (Variable, To => Token_Ptr); -- Scan past the variable name Scan; if Token = Tok_Colon then -- Typed string variable declaration Scan; Set_Kind_Of (Variable, N_Typed_Variable_Declaration); Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then String_Type_Name := Token_Name; Type_Location := Token_Ptr; Scan; if Token = Tok_Dot then Project_String_Type_Name := String_Type_Name; Project_Location := Type_Location; -- Scan past the dot Scan; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then String_Type_Name := Token_Name; Type_Location := Token_Ptr; Scan; else String_Type_Name := No_Name; end if; end if; if String_Type_Name /= No_Name then declare Current : Project_Node_Id := First_String_Type_Of (Current_Project); 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 (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); end if; end; end if; while Current /= Empty_Node and then Name_Of (Current) /= String_Type_Name loop Current := Next_String_Type (Current); end loop; if Current = Empty_Node then Error_Msg ("unknown string type """ & Get_Name_String (String_Type_Name) & """", Type_Location); else Set_String_Type_Of (Variable, To => Current); end if; end; end if; end if; end if; Expect (Tok_Colon_Equal, ":="); if Token = Tok_Colon_Equal then Scan; end if; -- Get the single string or string list value Expression_Location := Token_Ptr; Parse_Expression (Expression => Expression, Current_Project => Current_Project, Current_Package => Current_Package); Set_Expression_Of (Variable, To => Expression); if Expression /= Empty_Node then 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 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; end Parse_Variable_Declaration; end Prj.Dect;