| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . D E C T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2015, 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 3, 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 COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- 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 Opt; use Opt; |
| with Prj.Attr; use Prj.Attr; |
| with Prj.Attr.PM; use Prj.Attr.PM; |
| with Prj.Err; use Prj.Err; |
| with Prj.Strt; use Prj.Strt; |
| with Prj.Tree; use Prj.Tree; |
| with Snames; |
| with Uintp; use Uintp; |
| |
| with GNAT; use GNAT; |
| with GNAT.Case_Util; use GNAT.Case_Util; |
| with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; |
| with GNAT.Strings; |
| |
| 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 Rename_Obsolescent_Attributes |
| (In_Tree : Project_Node_Tree_Ref; |
| Attribute : Project_Node_Id; |
| Current_Package : Project_Node_Id); |
| -- Rename obsolescent attributes in the tree. When the attribute has been |
| -- renamed since its initial introduction in the design of projects, we |
| -- replace the old name in the tree with the new name, so that the code |
| -- does not have to check both names forever. |
| |
| procedure Check_Attribute_Allowed |
| (In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id; |
| Attribute : Project_Node_Id; |
| Flags : Processing_Flags); |
| -- Check whether the attribute is valid in this project. In particular, |
| -- depending on the type of project (qualifier), some attributes might |
| -- be disabled. |
| |
| procedure Check_Package_Allowed |
| (In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id; |
| Current_Package : Project_Node_Id; |
| Flags : Processing_Flags); |
| -- Check whether the package is valid in this 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; |
| Flags : Processing_Flags); |
| -- 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; |
| Is_Config_File : Boolean; |
| Flags : Processing_Flags); |
| -- 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; |
| Is_Config_File : Boolean; |
| Flags : Processing_Flags); |
| -- Parse declarative items. Depending on In_Zone, some declarative items |
| -- may be forbidden. Is_Config_File should be set to True if the project |
| -- represents a config file (.cgpr) since some specific checks apply. |
| |
| 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_Config_File : Boolean; |
| Flags : Processing_Flags); |
| -- Parse a package declaration. |
| -- Is_Config_File should be set to True if the project represents a config |
| -- file (.cgpr) since some specific checks apply. |
| |
| procedure Parse_String_Type_Declaration |
| (In_Tree : Project_Node_Tree_Ref; |
| String_Type : out Project_Node_Id; |
| Current_Project : Project_Node_Id; |
| Flags : Processing_Flags); |
| -- type <name> is ( <literal_string> { , <literal_string> } ) ; |
| |
| procedure Parse_Variable_Declaration |
| (In_Tree : Project_Node_Tree_Ref; |
| Variable : out Project_Node_Id; |
| Current_Project : Project_Node_Id; |
| Current_Package : Project_Node_Id; |
| Flags : Processing_Flags); |
| -- 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_Config_File : Boolean; |
| Flags : Processing_Flags) |
| 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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| Set_First_Declarative_Item_Of |
| (Declarations, In_Tree, To => First_Declarative_Item); |
| end Parse; |
| |
| ----------------------------------- |
| -- Rename_Obsolescent_Attributes -- |
| ----------------------------------- |
| |
| procedure Rename_Obsolescent_Attributes |
| (In_Tree : Project_Node_Tree_Ref; |
| Attribute : Project_Node_Id; |
| Current_Package : Project_Node_Id) |
| is |
| begin |
| if Present (Current_Package) |
| 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; |
| end Rename_Obsolescent_Attributes; |
| |
| --------------------------- |
| -- Check_Package_Allowed -- |
| --------------------------- |
| |
| procedure Check_Package_Allowed |
| (In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id; |
| Current_Package : Project_Node_Id; |
| Flags : Processing_Flags) |
| is |
| Qualif : constant Project_Qualifier := |
| Project_Qualifier_Of (Project, In_Tree); |
| Name : constant Name_Id := Name_Of (Current_Package, In_Tree); |
| begin |
| if Name /= Snames.Name_Ide |
| and then |
| ((Qualif = Aggregate and then Name /= Snames.Name_Builder) |
| or else |
| (Qualif = Aggregate_Library and then Name /= Snames.Name_Builder |
| and then Name /= Snames.Name_Install)) |
| then |
| Error_Msg_Name_1 := Name; |
| Error_Msg |
| (Flags, |
| "package %% is forbidden in aggregate projects", |
| Location_Of (Current_Package, In_Tree)); |
| end if; |
| end Check_Package_Allowed; |
| |
| ----------------------------- |
| -- Check_Attribute_Allowed -- |
| ----------------------------- |
| |
| procedure Check_Attribute_Allowed |
| (In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id; |
| Attribute : Project_Node_Id; |
| Flags : Processing_Flags) |
| is |
| Qualif : constant Project_Qualifier := |
| Project_Qualifier_Of (Project, In_Tree); |
| Name : constant Name_Id := Name_Of (Attribute, In_Tree); |
| |
| begin |
| case Qualif is |
| when Aggregate | Aggregate_Library => |
| if Name = Snames.Name_Languages |
| or else Name = Snames.Name_Source_Files |
| or else Name = Snames.Name_Source_List_File |
| or else Name = Snames.Name_Locally_Removed_Files |
| or else Name = Snames.Name_Excluded_Source_Files |
| or else Name = Snames.Name_Excluded_Source_List_File |
| or else Name = Snames.Name_Interfaces |
| or else Name = Snames.Name_Object_Dir |
| or else Name = Snames.Name_Exec_Dir |
| or else Name = Snames.Name_Source_Dirs |
| or else Name = Snames.Name_Inherit_Source_Path |
| or else |
| (Qualif = Aggregate and then Name = Snames.Name_Library_Dir) |
| or else |
| (Qualif = Aggregate and then Name = Snames.Name_Library_Name) |
| or else Name = Snames.Name_Main |
| or else Name = Snames.Name_Roots |
| or else Name = Snames.Name_Externally_Built |
| or else Name = Snames.Name_Executable |
| or else Name = Snames.Name_Executable_Suffix |
| or else Name = Snames.Name_Default_Switches |
| then |
| Error_Msg_Name_1 := Name; |
| Error_Msg |
| (Flags, |
| "%% is not valid in aggregate projects", |
| Location_Of (Attribute, In_Tree)); |
| end if; |
| |
| when others => |
| if Name = Snames.Name_Project_Files |
| or else Name = Snames.Name_Project_Path |
| or else Name = Snames.Name_External |
| then |
| Error_Msg_Name_1 := Name; |
| Error_Msg |
| (Flags, |
| "%% is only valid in aggregate projects", |
| Location_Of (Attribute, In_Tree)); |
| end if; |
| end case; |
| end Check_Attribute_Allowed; |
| |
| --------------------------------- |
| -- 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; |
| Flags : Processing_Flags) |
| 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; |
| |
| procedure Process_Attribute_Name; |
| -- Read the name of the attribute, and check its type |
| |
| procedure Process_Associative_Array_Index; |
| -- Read the index of the associative array and check its validity |
| |
| ---------------------------- |
| -- Process_Attribute_Name -- |
| ---------------------------- |
| |
| procedure Process_Attribute_Name is |
| Ignore : Boolean; |
| |
| begin |
| Attribute_Name := Token_Name; |
| Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); |
| Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); |
| |
| -- Find the attribute |
| |
| Current_Attribute := |
| Attribute_Node_Id_Of (Attribute_Name, First_Attribute); |
| |
| -- If the attribute cannot be found, create the attribute if inside |
| -- an unknown package. |
| |
| if Current_Attribute = Empty_Attribute then |
| if Present (Current_Package) |
| 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); |
| |
| else |
| -- If not a valid attribute name, issue an error if inside |
| -- a package that need to be checked. |
| |
| Ignore := Present (Current_Package) and then |
| Packages_To_Check /= All_Packages; |
| |
| if Ignore 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 |
| Ignore := False; |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| if not Ignore then |
| Error_Msg_Name_1 := Token_Name; |
| Error_Msg (Flags, "undefined attribute %%", Token_Ptr); |
| end if; |
| end if; |
| |
| -- Set, if appropriate the index case insensitivity flag |
| |
| else |
| if Is_Read_Only (Current_Attribute) then |
| Error_Msg_Name_1 := Token_Name; |
| Error_Msg |
| (Flags, "read-only attribute %% cannot be given a value", |
| Token_Ptr); |
| end if; |
| |
| if Attribute_Kind_Of (Current_Attribute) in |
| All_Case_Insensitive_Associative_Array |
| then |
| Set_Case_Insensitive (Attribute, In_Tree, To => True); |
| end if; |
| end if; |
| |
| Scan (In_Tree); -- past the attribute name |
| |
| -- 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; |
| end Process_Attribute_Name; |
| |
| ------------------------------------- |
| -- Process_Associative_Array_Index -- |
| ------------------------------------- |
| |
| procedure Process_Associative_Array_Index is |
| begin |
| -- 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 (Flags, |
| "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 |
| |
| if Others_Allowed_For (Current_Attribute) |
| and then Token = Tok_Others |
| then |
| Set_Associative_Array_Index_Of |
| (Attribute, In_Tree, All_Other_Names); |
| Scan (In_Tree); -- past others |
| |
| else |
| if Others_Allowed_For (Current_Attribute) then |
| Expect (Tok_String_Literal, "literal string or others"); |
| else |
| Expect (Tok_String_Literal, "literal string"); |
| end if; |
| |
| if Token = Tok_String_Literal then |
| Get_Name_String (Token_Name); |
| |
| if Case_Insensitive (Attribute, In_Tree) then |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| end if; |
| |
| Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); |
| 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 |
| (Flags, "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 (Flags, "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; |
| end if; |
| |
| Expect (Tok_Right_Paren, "`)`"); |
| |
| if Token = Tok_Right_Paren then |
| Scan (In_Tree); -- past the right parenthesis |
| end if; |
| end Process_Associative_Array_Index; |
| |
| 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 or External may be an attribute name |
| |
| if Token = Tok_Body then |
| Token := Tok_Identifier; |
| Token_Name := Snames.Name_Body; |
| end if; |
| |
| if Token = Tok_External then |
| Token := Tok_Identifier; |
| Token_Name := Snames.Name_External; |
| end if; |
| |
| Expect (Tok_Identifier, "identifier"); |
| Process_Attribute_Name; |
| Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package); |
| Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags); |
| |
| -- Associative array attributes |
| |
| if Token = Tok_Left_Paren then |
| Process_Associative_Array_Index; |
| |
| 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; |
| |
| 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 No (The_Project) and then not In_Tree.Incomplete_With then |
| Error_Msg (Flags, "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 Present (Current_Package) 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 |
| (Flags, "not the same package as " & |
| Get_Name_String |
| (Name_Of (Current_Package, In_Tree)), |
| Token_Ptr); |
| Scan (In_Tree); -- past the package name |
| |
| else |
| if Present (The_Project) then |
| The_Package := |
| First_Package_Of (The_Project, In_Tree); |
| |
| -- Look for the package node |
| |
| while Present (The_Package) |
| 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 No (The_Package) then |
| The_Project := Empty_Node; |
| Error_Msg_Name_2 := Project_Name; |
| Error_Msg_Name_1 := Token_Name; |
| Error_Msg |
| (Flags, |
| "package % not declared in project %", |
| Token_Ptr); |
| end if; |
| end if; |
| |
| Scan (In_Tree); -- past the package name |
| end if; |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| if Present (The_Project) or else In_Tree.Incomplete_With 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 |
| (Flags, "invalid name, should be %", Token_Ptr); |
| end if; |
| |
| Scan (In_Tree); -- past the attribute name |
| end if; |
| end if; |
| end if; |
| |
| if No (The_Project) 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, |
| Flags => Flags, |
| 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 Present (Expression) |
| 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 |
| (Flags, "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_Config_File : Boolean; |
| Flags : Processing_Flags) |
| 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, |
| Flags => Flags, |
| 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 Present (Case_Variable) then |
| String_Type := String_Type_Of (Case_Variable, In_Tree); |
| |
| if Expression_Kind_Of (Case_Variable, In_Tree) /= Single then |
| Error_Msg (Flags, |
| "variable """ & |
| Get_Name_String (Name_Of (Case_Variable, In_Tree)) & |
| """ is not a single string", |
| 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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| |
| -- "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, |
| Flags => Flags, |
| String_Type => Present (String_Type)); |
| 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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| |
| 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), |
| Flags => Flags, |
| String_Type => Present (String_Type)); |
| |
| 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_Config_File : Boolean; |
| Flags : Processing_Flags) |
| 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 |
| |
| -- Check if the variable has already been declared |
| |
| declare |
| The_Variable : Project_Node_Id := Empty_Node; |
| |
| begin |
| if Present (Current_Package) then |
| The_Variable := |
| First_Variable_Of (Current_Package, In_Tree); |
| elsif Present (Current_Project) then |
| The_Variable := |
| First_Variable_Of (Current_Project, In_Tree); |
| end if; |
| |
| while Present (The_Variable) |
| and then Name_Of (The_Variable, In_Tree) /= |
| Token_Name |
| loop |
| The_Variable := Next_Variable (The_Variable, In_Tree); |
| end loop; |
| |
| -- It is an error to declare a variable in a case |
| -- construction for the first time. |
| |
| if No (The_Variable) then |
| Error_Msg |
| (Flags, |
| "a variable cannot be declared " & |
| "for the first time here", |
| Token_Ptr); |
| end if; |
| end; |
| end if; |
| |
| Parse_Variable_Declaration |
| (In_Tree, |
| Current_Declaration, |
| Current_Project => Current_Project, |
| Current_Package => Current_Package, |
| Flags => Flags); |
| |
| 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, |
| Flags => Flags); |
| |
| 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 |
| (Flags, "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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| |
| Set_Previous_End_Node (Current_Declaration); |
| |
| when Tok_Type => |
| |
| -- Type String Declaration |
| |
| if In_Zone /= In_Project then |
| Error_Msg (Flags, |
| "a string type cannot be declared here", |
| Token_Ptr); |
| end if; |
| |
| Parse_String_Type_Declaration |
| (In_Tree => In_Tree, |
| String_Type => Current_Declaration, |
| Current_Project => Current_Project, |
| Flags => Flags); |
| |
| 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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| |
| Set_Previous_End_Node (Current_Declaration); |
| |
| when others => |
| exit; |
| |
| -- We are leaving Parse_Declarative_Items positioned |
| -- 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 Present (Current_Declaration) then |
| if No (Current_Declarative_Item) 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_Config_File : Boolean; |
| Flags : Processing_Flags) |
| is |
| First_Attribute : Attribute_Node_Id := Empty_Attribute; |
| Current_Package : Package_Node_Id := Empty_Package; |
| First_Declarative_Item : Project_Node_Id := Empty_Node; |
| Package_Location : constant Source_Ptr := Token_Ptr; |
| Renaming : Boolean := False; |
| Extending : Boolean := False; |
| |
| begin |
| Package_Declaration := |
| Default_Project_Node |
| (Of_Kind => N_Package_Declaration, In_Tree => In_Tree); |
| Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location); |
| |
| -- 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 |
| if not Quiet_Output then |
| declare |
| List : constant Strings.String_List := Package_Name_List; |
| Index : Natural; |
| Name : constant String := Get_Name_String (Token_Name); |
| |
| begin |
| -- Check for possible misspelling of a known package name |
| |
| Index := 0; |
| loop |
| if Index >= List'Last then |
| Index := 0; |
| exit; |
| end if; |
| |
| Index := Index + 1; |
| exit when |
| GNAT.Spelling_Checker.Is_Bad_Spelling_Of |
| (Name, List (Index).all); |
| end loop; |
| |
| -- Issue warning(s) in verbose mode or when a possible |
| -- misspelling has been found. |
| |
| if Verbose_Mode or else Index /= 0 then |
| Error_Msg (Flags, |
| "?""" & |
| Get_Name_String |
| (Name_Of (Package_Declaration, In_Tree)) & |
| """ is not a known package name", |
| Token_Ptr); |
| end if; |
| |
| if Index /= 0 then |
| Error_Msg -- CODEFIX |
| (Flags, |
| "\?possible misspelling of """ & |
| List (Index).all & """", Token_Ptr); |
| end if; |
| end; |
| end if; |
| |
| -- 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); |
| |
| elsif Current_Package = Unknown_Package then |
| |
| -- 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); |
| |
| else |
| First_Attribute := First_Attribute_Of (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 Present (Current) |
| and then Name_Of (Current, In_Tree) /= Token_Name |
| loop |
| Current := Next_Package_In_Project (Current, In_Tree); |
| end loop; |
| |
| if Present (Current) then |
| Error_Msg |
| (Flags, |
| "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; |
| |
| Check_Package_Allowed |
| (In_Tree, Current_Project, Package_Declaration, Flags); |
| |
| if Token = Tok_Renames then |
| Renaming := True; |
| elsif Token = Tok_Extends then |
| Extending := True; |
| end if; |
| |
| if Renaming or else Extending then |
| if Is_Config_File then |
| Error_Msg |
| (Flags, |
| "no package rename or extension in configuration projects", |
| Token_Ptr); |
| end if; |
| |
| -- Scan past "renames" or "extends" |
| |
| 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 Present (Clause) 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 Present (The_Project) |
| and then Name_Of (The_Project, In_Tree) = Project_Name; |
| Clause := Next_With_Clause_Of (Clause, In_Tree); |
| end loop; |
| |
| if No (Clause) then |
| -- As we have not found the project in the imports, we check |
| -- if it's the name of an eventual extended project. |
| |
| if Present (Extended) |
| 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 |
| (Flags, |
| "% 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 (Flags, "not the same package name", Token_Ptr); |
| elsif |
| Present (Project_Of_Renamed_Package_Of |
| (Package_Declaration, In_Tree)) |
| then |
| declare |
| Current : Project_Node_Id := |
| First_Package_Of |
| (Project_Of_Renamed_Package_Of |
| (Package_Declaration, In_Tree), |
| In_Tree); |
| |
| begin |
| while Present (Current) |
| and then Name_Of (Current, In_Tree) /= Token_Name |
| loop |
| Current := |
| Next_Package_In_Project (Current, In_Tree); |
| end loop; |
| |
| if No (Current) then |
| Error_Msg |
| (Flags, """" & |
| 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; |
| end if; |
| |
| if Renaming then |
| 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, |
| Is_Config_File => Is_Config_File, |
| Flags => Flags); |
| |
| 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 (Flags, "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 (Flags, "expected IS", 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; |
| Flags : Processing_Flags) |
| 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 Present (Current) |
| and then |
| Name_Of (Current, In_Tree) /= Token_Name |
| loop |
| Current := Next_String_Type (Current, In_Tree); |
| end loop; |
| |
| if Present (Current) then |
| Error_Msg (Flags, |
| "duplicate string type name """ & |
| Get_Name_String (Token_Name) & |
| """", |
| Token_Ptr); |
| else |
| Current := First_Variable_Of (Current_Project, In_Tree); |
| while Present (Current) |
| and then Name_Of (Current, In_Tree) /= Token_Name |
| loop |
| Current := Next_Variable (Current, In_Tree); |
| end loop; |
| |
| if Present (Current) then |
| Error_Msg (Flags, |
| """" & |
| 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, Flags => Flags); |
| 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; |
| Flags : Processing_Flags) |
| 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 |
| Proj : Project_Node_Id := Current_Project; |
| Current : Project_Node_Id := Empty_Node; |
| |
| 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 (Flags, |
| "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); |
| while |
| Present (Current) |
| and then |
| Name_Of (Current, In_Tree) /= String_Type_Name |
| loop |
| Current := Next_String_Type (Current, In_Tree); |
| end loop; |
| end if; |
| end; |
| |
| else |
| -- Look for a string type with the correct name in this |
| -- project or in any of its ancestors. |
| |
| loop |
| Current := |
| First_String_Type_Of (Proj, In_Tree); |
| while |
| Present (Current) |
| and then |
| Name_Of (Current, In_Tree) /= String_Type_Name |
| loop |
| Current := Next_String_Type (Current, In_Tree); |
| end loop; |
| |
| exit when Present (Current); |
| |
| Proj := Parent_Project_Of (Proj, In_Tree); |
| exit when No (Proj); |
| end loop; |
| end if; |
| |
| if No (Current) then |
| Error_Msg (Flags, |
| "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 then 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, |
| Flags => Flags, |
| Current_Project => Current_Project, |
| Current_Package => Current_Package, |
| Optional_Index => False); |
| Set_Expression_Of (Variable, In_Tree, To => Expression); |
| |
| if Present (Expression) 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 |
| (Flags, |
| "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 Present (Current_Package) then |
| The_Variable := First_Variable_Of (Current_Package, In_Tree); |
| elsif Present (Current_Project) then |
| The_Variable := First_Variable_Of (Current_Project, In_Tree); |
| end if; |
| |
| while Present (The_Variable) |
| and then Name_Of (The_Variable, In_Tree) /= Variable_Name |
| loop |
| The_Variable := Next_Variable (The_Variable, In_Tree); |
| end loop; |
| |
| if No (The_Variable) then |
| if Present (Current_Package) 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 Present (Current_Project) 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 (Flags, |
| "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; |
