blob: 461bd87f56b17753689717f18505dfe5efc70377 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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;