------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . D E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2004 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 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 Scans; use Scans; with Snames; with Types; use Types; 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 (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_Extended_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; 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); Set_Location_Of (Attribute, To => Token_Ptr); Set_Previous_Line_Node (Attribute); -- Scan past "for" 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 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) = Ignored then Pkg_Id := Package_Id_Of (Current_Package); 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 Current_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)); 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; Error_Msg_Name_1 := Token_Name; if Warning then Error_Msg ("?undefined attribute {", Token_Ptr); else Error_Msg ("undefined attribute {", Token_Ptr); end if; 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, To => True); end if; Scan; -- 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) /= Ignored then 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; 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)); elsif Attribute_Kind_Of (Current_Attribute) = Unknown then Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); end if; Scan; -- past the left parenthesis Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Set_Associative_Array_Index_Of (Attribute, Token_Name); Scan; -- 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; 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, To => Index); end if; end; Scan; end if; when others => Error_Msg ("index not allowed here", Token_Ptr); Scan; if Token = Tok_Integer_Literal then Scan; end if; end case; end if; end if; Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then 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 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, 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; if Full_Associative_Array then -- Expect ', or -- .' 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 ' 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, Optional_Index => Optional_Index); 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 Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression) then if Variable_Kind_Of (Current_Attribute) = Undefined then Set_Variable_Kind_Of (Current_Attribute, To => Expression_Kind_Of (Expression)); 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 (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; 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); 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 Set_End_Of_Line (Case_Construction); Set_Previous_Line_Node (Case_Construction); Set_Next_End_Node (Case_Construction); -- 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 When_Others := True; -- Scan past "others" Scan; 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, 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, "`=>`"); Set_End_Of_Line (Current_Item); Set_Previous_Line_Node (Current_Item); 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 (Check_All_Labels => not When_Others and not Quiet_Output, Case_Location => Location_Of (Case_Construction)); Expect (Tok_End, "`END CASE`"); Remove_Next_End_Node; if Token = Tok_End then -- Scan past "end" Scan; Expect (Tok_Case, "CASE"); end if; -- Scan past "case" Scan; Expect (Tok_Semicolon, "`;`"); Set_Previous_End_Node (Case_Construction); 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); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); when Tok_For => Parse_Attribute_Declaration (Attribute => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); when Tok_Null => Scan; -- 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 (Package_Declaration => Current_Declaration, Current_Project => Current_Project); 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 (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 (Case_Construction => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); 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); 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 if; 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); 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)) & """ 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, 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, 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; -- 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 : 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 -- 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 -- 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); 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, "`;`"); 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 (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, "`;`"); 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 (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; OK : Boolean := True; 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"); OK := Token = Tok_Identifier; if OK 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 OK := False; end if; end if; if OK 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); OK := False; else Set_String_Type_Of (Variable, 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; 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, Optional_Index => False); 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; 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); 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 if; end Parse_Variable_Declaration; end Prj.Dect;