------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- P R J . D E C T --
|
-- P R J . D E C T --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- 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- --
|
-- 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- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- 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 --
|
-- 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 --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Err_Vars; use Err_Vars;
|
with Err_Vars; use Err_Vars;
|
with Opt; use Opt;
|
with Opt; use Opt;
|
with Prj.Attr; use Prj.Attr;
|
with Prj.Attr; use Prj.Attr;
|
with Prj.Attr.PM; use Prj.Attr.PM;
|
with Prj.Attr.PM; use Prj.Attr.PM;
|
with Prj.Err; use Prj.Err;
|
with Prj.Err; use Prj.Err;
|
with Prj.Strt; use Prj.Strt;
|
with Prj.Strt; use Prj.Strt;
|
with Prj.Tree; use Prj.Tree;
|
with Prj.Tree; use Prj.Tree;
|
with Snames;
|
with Snames;
|
with Uintp; use Uintp;
|
with Uintp; use Uintp;
|
|
|
with GNAT; use GNAT;
|
with GNAT; use GNAT;
|
with GNAT.Case_Util; use GNAT.Case_Util;
|
with GNAT.Case_Util; use GNAT.Case_Util;
|
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
|
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
|
with GNAT.Strings;
|
with GNAT.Strings;
|
|
|
package body Prj.Dect is
|
package body Prj.Dect is
|
|
|
type Zone is (In_Project, In_Package, In_Case_Construction);
|
type Zone is (In_Project, In_Package, In_Case_Construction);
|
-- Used to indicate if we are parsing a package (In_Package), a case
|
-- Used to indicate if we are parsing a package (In_Package), a case
|
-- construction (In_Case_Construction) or none of those two (In_Project).
|
-- construction (In_Case_Construction) or none of those two (In_Project).
|
|
|
procedure Rename_Obsolescent_Attributes
|
procedure Rename_Obsolescent_Attributes
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Attribute : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Current_Package : Project_Node_Id);
|
Current_Package : Project_Node_Id);
|
-- Rename obsolescent attributes in the tree. When the attribute has been
|
-- Rename obsolescent attributes in the tree. When the attribute has been
|
-- renamed since its initial introduction in the design of projects, we
|
-- 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
|
-- replace the old name in the tree with the new name, so that the code
|
-- does not have to check both names forever.
|
-- does not have to check both names forever.
|
|
|
procedure Check_Attribute_Allowed
|
procedure Check_Attribute_Allowed
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Project : Project_Node_Id;
|
Project : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Check whether the attribute is valid in this project. In particular,
|
-- Check whether the attribute is valid in this project. In particular,
|
-- depending on the type of project (qualifier), some attributes might
|
-- depending on the type of project (qualifier), some attributes might
|
-- be disabled.
|
-- be disabled.
|
|
|
procedure Check_Package_Allowed
|
procedure Check_Package_Allowed
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Project : Project_Node_Id;
|
Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Check whether the package is valid in this project
|
-- Check whether the package is valid in this project
|
|
|
procedure Parse_Attribute_Declaration
|
procedure Parse_Attribute_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Attribute : out Project_Node_Id;
|
Attribute : out Project_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Parse an attribute declaration
|
-- Parse an attribute declaration
|
|
|
procedure Parse_Case_Construction
|
procedure Parse_Case_Construction
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Case_Construction : out Project_Node_Id;
|
Case_Construction : out Project_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Parse a case construction
|
-- Parse a case construction
|
|
|
procedure Parse_Declarative_Items
|
procedure Parse_Declarative_Items
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Declarations : out Project_Node_Id;
|
Declarations : out Project_Node_Id;
|
In_Zone : Zone;
|
In_Zone : Zone;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Parse declarative items. Depending on In_Zone, some declarative items
|
-- Parse declarative items. Depending on In_Zone, some declarative items
|
-- may be forbidden. Is_Config_File should be set to True if the project
|
-- may be forbidden. Is_Config_File should be set to True if the project
|
-- represents a config file (.cgpr) since some specific checks apply.
|
-- represents a config file (.cgpr) since some specific checks apply.
|
|
|
procedure Parse_Package_Declaration
|
procedure Parse_Package_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Package_Declaration : out Project_Node_Id;
|
Package_Declaration : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Parse a package declaration.
|
-- Parse a package declaration.
|
-- Is_Config_File should be set to True if the project represents a config
|
-- Is_Config_File should be set to True if the project represents a config
|
-- file (.cgpr) since some specific checks apply.
|
-- file (.cgpr) since some specific checks apply.
|
|
|
procedure Parse_String_Type_Declaration
|
procedure Parse_String_Type_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
String_Type : out Project_Node_Id;
|
String_Type : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- type <name> is ( <literal_string> { , <literal_string> } ) ;
|
-- type <name> is ( <literal_string> { , <literal_string> } ) ;
|
|
|
procedure Parse_Variable_Declaration
|
procedure Parse_Variable_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Variable : out Project_Node_Id;
|
Variable : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Flags : Processing_Flags);
|
Flags : Processing_Flags);
|
-- Parse a variable assignment
|
-- Parse a variable assignment
|
-- <variable_Name> := <expression>; OR
|
-- <variable_Name> := <expression>; OR
|
-- <variable_Name> : <string_type_Name> := <string_expression>;
|
-- <variable_Name> : <string_type_Name> := <string_expression>;
|
|
|
-----------
|
-----------
|
-- Parse --
|
-- Parse --
|
-----------
|
-----------
|
|
|
procedure Parse
|
procedure Parse
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Declarations : out Project_Node_Id;
|
Declarations : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Extends : Project_Node_Id;
|
Extends : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
|
|
begin
|
begin
|
Declarations :=
|
Declarations :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
|
(Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
|
Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
|
Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
|
Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
|
Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
|
Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
|
Parse_Declarative_Items
|
Parse_Declarative_Items
|
(Declarations => First_Declarative_Item,
|
(Declarations => First_Declarative_Item,
|
In_Tree => In_Tree,
|
In_Tree => In_Tree,
|
In_Zone => In_Project,
|
In_Zone => In_Project,
|
First_Attribute => Prj.Attr.Attribute_First,
|
First_Attribute => Prj.Attr.Attribute_First,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Empty_Node,
|
Current_Package => Empty_Node,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
Set_First_Declarative_Item_Of
|
Set_First_Declarative_Item_Of
|
(Declarations, In_Tree, To => First_Declarative_Item);
|
(Declarations, In_Tree, To => First_Declarative_Item);
|
end Parse;
|
end Parse;
|
|
|
-----------------------------------
|
-----------------------------------
|
-- Rename_Obsolescent_Attributes --
|
-- Rename_Obsolescent_Attributes --
|
-----------------------------------
|
-----------------------------------
|
|
|
procedure Rename_Obsolescent_Attributes
|
procedure Rename_Obsolescent_Attributes
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Attribute : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Current_Package : Project_Node_Id)
|
Current_Package : Project_Node_Id)
|
is
|
is
|
begin
|
begin
|
if Present (Current_Package)
|
if Present (Current_Package)
|
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
|
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
|
then
|
then
|
case Name_Of (Attribute, In_Tree) is
|
case Name_Of (Attribute, In_Tree) is
|
when Snames.Name_Specification =>
|
when Snames.Name_Specification =>
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
|
|
|
when Snames.Name_Specification_Suffix =>
|
when Snames.Name_Specification_Suffix =>
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
|
|
|
when Snames.Name_Implementation =>
|
when Snames.Name_Implementation =>
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
|
|
|
when Snames.Name_Implementation_Suffix =>
|
when Snames.Name_Implementation_Suffix =>
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
|
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
|
|
|
when others =>
|
when others =>
|
null;
|
null;
|
end case;
|
end case;
|
end if;
|
end if;
|
end Rename_Obsolescent_Attributes;
|
end Rename_Obsolescent_Attributes;
|
|
|
---------------------------
|
---------------------------
|
-- Check_Package_Allowed --
|
-- Check_Package_Allowed --
|
---------------------------
|
---------------------------
|
|
|
procedure Check_Package_Allowed
|
procedure Check_Package_Allowed
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Project : Project_Node_Id;
|
Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Qualif : constant Project_Qualifier :=
|
Qualif : constant Project_Qualifier :=
|
Project_Qualifier_Of (Project, In_Tree);
|
Project_Qualifier_Of (Project, In_Tree);
|
Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
|
Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
|
begin
|
begin
|
if Qualif in Aggregate_Project
|
if Qualif in Aggregate_Project
|
and then Name /= Snames.Name_Builder
|
and then Name /= Snames.Name_Builder
|
then
|
then
|
Error_Msg_Name_1 := Name;
|
Error_Msg_Name_1 := Name;
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"package %% is forbidden in aggregate projects",
|
"package %% is forbidden in aggregate projects",
|
Location_Of (Current_Package, In_Tree));
|
Location_Of (Current_Package, In_Tree));
|
end if;
|
end if;
|
end Check_Package_Allowed;
|
end Check_Package_Allowed;
|
|
|
-----------------------------
|
-----------------------------
|
-- Check_Attribute_Allowed --
|
-- Check_Attribute_Allowed --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Check_Attribute_Allowed
|
procedure Check_Attribute_Allowed
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Project : Project_Node_Id;
|
Project : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Attribute : Project_Node_Id;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Qualif : constant Project_Qualifier :=
|
Qualif : constant Project_Qualifier :=
|
Project_Qualifier_Of (Project, In_Tree);
|
Project_Qualifier_Of (Project, In_Tree);
|
Name : constant Name_Id := Name_Of (Attribute, In_Tree);
|
Name : constant Name_Id := Name_Of (Attribute, In_Tree);
|
|
|
begin
|
begin
|
case Qualif is
|
case Qualif is
|
when Aggregate | Aggregate_Library =>
|
when Aggregate | Aggregate_Library =>
|
if Name = Snames.Name_Languages
|
if Name = Snames.Name_Languages
|
or else Name = Snames.Name_Source_Files
|
or else Name = Snames.Name_Source_Files
|
or else Name = Snames.Name_Source_List_File
|
or else Name = Snames.Name_Source_List_File
|
or else Name = Snames.Name_Locally_Removed_Files
|
or else Name = Snames.Name_Locally_Removed_Files
|
or else Name = Snames.Name_Excluded_Source_Files
|
or else Name = Snames.Name_Excluded_Source_Files
|
or else Name = Snames.Name_Excluded_Source_List_File
|
or else Name = Snames.Name_Excluded_Source_List_File
|
or else Name = Snames.Name_Interfaces
|
or else Name = Snames.Name_Interfaces
|
or else Name = Snames.Name_Object_Dir
|
or else Name = Snames.Name_Object_Dir
|
or else Name = Snames.Name_Exec_Dir
|
or else Name = Snames.Name_Exec_Dir
|
or else Name = Snames.Name_Source_Dirs
|
or else Name = Snames.Name_Source_Dirs
|
or else Name = Snames.Name_Inherit_Source_Path
|
or else Name = Snames.Name_Inherit_Source_Path
|
then
|
then
|
Error_Msg_Name_1 := Name;
|
Error_Msg_Name_1 := Name;
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"%% is not valid in aggregate projects",
|
"%% is not valid in aggregate projects",
|
Location_Of (Attribute, In_Tree));
|
Location_Of (Attribute, In_Tree));
|
end if;
|
end if;
|
|
|
when others =>
|
when others =>
|
if Name = Snames.Name_Project_Files
|
if Name = Snames.Name_Project_Files
|
or else Name = Snames.Name_Project_Path
|
or else Name = Snames.Name_Project_Path
|
or else Name = Snames.Name_External
|
or else Name = Snames.Name_External
|
then
|
then
|
Error_Msg_Name_1 := Name;
|
Error_Msg_Name_1 := Name;
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"%% is only valid in aggregate projects",
|
"%% is only valid in aggregate projects",
|
Location_Of (Attribute, In_Tree));
|
Location_Of (Attribute, In_Tree));
|
end if;
|
end if;
|
end case;
|
end case;
|
end Check_Attribute_Allowed;
|
end Check_Attribute_Allowed;
|
|
|
---------------------------------
|
---------------------------------
|
-- Parse_Attribute_Declaration --
|
-- Parse_Attribute_Declaration --
|
---------------------------------
|
---------------------------------
|
|
|
procedure Parse_Attribute_Declaration
|
procedure Parse_Attribute_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Attribute : out Project_Node_Id;
|
Attribute : out Project_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Current_Attribute : Attribute_Node_Id := First_Attribute;
|
Current_Attribute : Attribute_Node_Id := First_Attribute;
|
Full_Associative_Array : Boolean := False;
|
Full_Associative_Array : Boolean := False;
|
Attribute_Name : Name_Id := No_Name;
|
Attribute_Name : Name_Id := No_Name;
|
Optional_Index : Boolean := False;
|
Optional_Index : Boolean := False;
|
Pkg_Id : Package_Node_Id := Empty_Package;
|
Pkg_Id : Package_Node_Id := Empty_Package;
|
|
|
procedure Process_Attribute_Name;
|
procedure Process_Attribute_Name;
|
-- Read the name of the attribute, and check its type
|
-- Read the name of the attribute, and check its type
|
|
|
procedure Process_Associative_Array_Index;
|
procedure Process_Associative_Array_Index;
|
-- Read the index of the associative array and check its validity
|
-- Read the index of the associative array and check its validity
|
|
|
----------------------------
|
----------------------------
|
-- Process_Attribute_Name --
|
-- Process_Attribute_Name --
|
----------------------------
|
----------------------------
|
|
|
procedure Process_Attribute_Name is
|
procedure Process_Attribute_Name is
|
Ignore : Boolean;
|
Ignore : Boolean;
|
|
|
begin
|
begin
|
Attribute_Name := Token_Name;
|
Attribute_Name := Token_Name;
|
Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
|
Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
|
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
|
|
|
-- Find the attribute
|
-- Find the attribute
|
|
|
Current_Attribute :=
|
Current_Attribute :=
|
Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
|
Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
|
|
|
-- If the attribute cannot be found, create the attribute if inside
|
-- If the attribute cannot be found, create the attribute if inside
|
-- an unknown package.
|
-- an unknown package.
|
|
|
if Current_Attribute = Empty_Attribute then
|
if Current_Attribute = Empty_Attribute then
|
if Present (Current_Package)
|
if Present (Current_Package)
|
and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
|
and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
|
then
|
then
|
Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
|
Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
|
Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
|
Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
|
|
|
else
|
else
|
-- If not a valid attribute name, issue an error if inside
|
-- If not a valid attribute name, issue an error if inside
|
-- a package that need to be checked.
|
-- a package that need to be checked.
|
|
|
Ignore := Present (Current_Package) and then
|
Ignore := Present (Current_Package) and then
|
Packages_To_Check /= All_Packages;
|
Packages_To_Check /= All_Packages;
|
|
|
if Ignore then
|
if Ignore then
|
|
|
-- Check that we are not in a package to check
|
-- Check that we are not in a package to check
|
|
|
Get_Name_String (Name_Of (Current_Package, In_Tree));
|
Get_Name_String (Name_Of (Current_Package, In_Tree));
|
|
|
for Index in Packages_To_Check'Range loop
|
for Index in Packages_To_Check'Range loop
|
if Name_Buffer (1 .. Name_Len) =
|
if Name_Buffer (1 .. Name_Len) =
|
Packages_To_Check (Index).all
|
Packages_To_Check (Index).all
|
then
|
then
|
Ignore := False;
|
Ignore := False;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
if not Ignore then
|
if not Ignore then
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
|
Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Set, if appropriate the index case insensitivity flag
|
-- Set, if appropriate the index case insensitivity flag
|
|
|
else
|
else
|
if Is_Read_Only (Current_Attribute) then
|
if Is_Read_Only (Current_Attribute) then
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg
|
Error_Msg
|
(Flags, "read-only attribute %% cannot be given a value",
|
(Flags, "read-only attribute %% cannot be given a value",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
|
|
if Attribute_Kind_Of (Current_Attribute) in
|
if Attribute_Kind_Of (Current_Attribute) in
|
All_Case_Insensitive_Associative_Array
|
All_Case_Insensitive_Associative_Array
|
then
|
then
|
Set_Case_Insensitive (Attribute, In_Tree, To => True);
|
Set_Case_Insensitive (Attribute, In_Tree, To => True);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Scan (In_Tree); -- past the attribute name
|
Scan (In_Tree); -- past the attribute name
|
|
|
-- Set the expression kind of the attribute
|
-- Set the expression kind of the attribute
|
|
|
if Current_Attribute /= Empty_Attribute then
|
if Current_Attribute /= Empty_Attribute then
|
Set_Expression_Kind_Of
|
Set_Expression_Kind_Of
|
(Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
|
(Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
|
Optional_Index := Optional_Index_Of (Current_Attribute);
|
Optional_Index := Optional_Index_Of (Current_Attribute);
|
end if;
|
end if;
|
end Process_Attribute_Name;
|
end Process_Attribute_Name;
|
|
|
-------------------------------------
|
-------------------------------------
|
-- Process_Associative_Array_Index --
|
-- Process_Associative_Array_Index --
|
-------------------------------------
|
-------------------------------------
|
|
|
procedure Process_Associative_Array_Index is
|
procedure Process_Associative_Array_Index is
|
begin
|
begin
|
-- If the attribute is not an associative array attribute, report
|
-- If the attribute is not an associative array attribute, report
|
-- an error. If this information is still unknown, set the kind
|
-- an error. If this information is still unknown, set the kind
|
-- to Associative_Array.
|
-- to Associative_Array.
|
|
|
if Current_Attribute /= Empty_Attribute
|
if Current_Attribute /= Empty_Attribute
|
and then Attribute_Kind_Of (Current_Attribute) = Single
|
and then Attribute_Kind_Of (Current_Attribute) = Single
|
then
|
then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"the attribute """ &
|
"the attribute """ &
|
Get_Name_String (Attribute_Name_Of (Current_Attribute))
|
Get_Name_String (Attribute_Name_Of (Current_Attribute))
|
& """ cannot be an associative array",
|
& """ cannot be an associative array",
|
Location_Of (Attribute, In_Tree));
|
Location_Of (Attribute, In_Tree));
|
|
|
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
|
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
|
Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
|
Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
|
end if;
|
end if;
|
|
|
Scan (In_Tree); -- past the left parenthesis
|
Scan (In_Tree); -- past the left parenthesis
|
|
|
if Others_Allowed_For (Current_Attribute)
|
if Others_Allowed_For (Current_Attribute)
|
and then Token = Tok_Others
|
and then Token = Tok_Others
|
then
|
then
|
Set_Associative_Array_Index_Of
|
Set_Associative_Array_Index_Of
|
(Attribute, In_Tree, All_Other_Names);
|
(Attribute, In_Tree, All_Other_Names);
|
Scan (In_Tree); -- past others
|
Scan (In_Tree); -- past others
|
|
|
else
|
else
|
if Others_Allowed_For (Current_Attribute) then
|
if Others_Allowed_For (Current_Attribute) then
|
Expect (Tok_String_Literal, "literal string or others");
|
Expect (Tok_String_Literal, "literal string or others");
|
else
|
else
|
Expect (Tok_String_Literal, "literal string");
|
Expect (Tok_String_Literal, "literal string");
|
end if;
|
end if;
|
|
|
if Token = Tok_String_Literal then
|
if Token = Tok_String_Literal then
|
Get_Name_String (Token_Name);
|
Get_Name_String (Token_Name);
|
|
|
if Case_Insensitive (Attribute, In_Tree) then
|
if Case_Insensitive (Attribute, In_Tree) then
|
To_Lower (Name_Buffer (1 .. Name_Len));
|
To_Lower (Name_Buffer (1 .. Name_Len));
|
end if;
|
end if;
|
|
|
Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
|
Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
|
Scan (In_Tree); -- past the literal string index
|
Scan (In_Tree); -- past the literal string index
|
|
|
if Token = Tok_At then
|
if Token = Tok_At then
|
case Attribute_Kind_Of (Current_Attribute) is
|
case Attribute_Kind_Of (Current_Attribute) is
|
when Optional_Index_Associative_Array |
|
when Optional_Index_Associative_Array |
|
Optional_Index_Case_Insensitive_Associative_Array =>
|
Optional_Index_Case_Insensitive_Associative_Array =>
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Expect (Tok_Integer_Literal, "integer literal");
|
Expect (Tok_Integer_Literal, "integer literal");
|
|
|
if Token = Tok_Integer_Literal then
|
if Token = Tok_Integer_Literal then
|
|
|
-- Set the source index value from given literal
|
-- Set the source index value from given literal
|
|
|
declare
|
declare
|
Index : constant Int :=
|
Index : constant Int :=
|
UI_To_Int (Int_Literal_Value);
|
UI_To_Int (Int_Literal_Value);
|
begin
|
begin
|
if Index = 0 then
|
if Index = 0 then
|
Error_Msg
|
Error_Msg
|
(Flags, "index cannot be zero", Token_Ptr);
|
(Flags, "index cannot be zero", Token_Ptr);
|
else
|
else
|
Set_Source_Index_Of
|
Set_Source_Index_Of
|
(Attribute, In_Tree, To => Index);
|
(Attribute, In_Tree, To => Index);
|
end if;
|
end if;
|
end;
|
end;
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
when others =>
|
when others =>
|
Error_Msg (Flags, "index not allowed here", Token_Ptr);
|
Error_Msg (Flags, "index not allowed here", Token_Ptr);
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
if Token = Tok_Integer_Literal then
|
if Token = Tok_Integer_Literal then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
end case;
|
end case;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Expect (Tok_Right_Paren, "`)`");
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
if Token = Tok_Right_Paren then
|
if Token = Tok_Right_Paren then
|
Scan (In_Tree); -- past the right parenthesis
|
Scan (In_Tree); -- past the right parenthesis
|
end if;
|
end if;
|
end Process_Associative_Array_Index;
|
end Process_Associative_Array_Index;
|
|
|
begin
|
begin
|
Attribute :=
|
Attribute :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
|
(Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
|
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
|
Set_Previous_Line_Node (Attribute);
|
Set_Previous_Line_Node (Attribute);
|
|
|
-- Scan past "for"
|
-- Scan past "for"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
-- Body or External may be an attribute name
|
-- Body or External may be an attribute name
|
|
|
if Token = Tok_Body then
|
if Token = Tok_Body then
|
Token := Tok_Identifier;
|
Token := Tok_Identifier;
|
Token_Name := Snames.Name_Body;
|
Token_Name := Snames.Name_Body;
|
end if;
|
end if;
|
|
|
if Token = Tok_External then
|
if Token = Tok_External then
|
Token := Tok_Identifier;
|
Token := Tok_Identifier;
|
Token_Name := Snames.Name_External;
|
Token_Name := Snames.Name_External;
|
end if;
|
end if;
|
|
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
Process_Attribute_Name;
|
Process_Attribute_Name;
|
Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
|
Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
|
Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
|
Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
|
|
|
-- Associative array attributes
|
-- Associative array attributes
|
|
|
if Token = Tok_Left_Paren then
|
if Token = Tok_Left_Paren then
|
Process_Associative_Array_Index;
|
Process_Associative_Array_Index;
|
|
|
else
|
else
|
-- If it is an associative array attribute and there are no left
|
-- If it is an associative array attribute and there are no left
|
-- parenthesis, then this is a full associative array declaration.
|
-- parenthesis, then this is a full associative array declaration.
|
-- Flag it as such for later processing of its value.
|
-- Flag it as such for later processing of its value.
|
|
|
if Current_Attribute /= Empty_Attribute
|
if Current_Attribute /= Empty_Attribute
|
and then
|
and then
|
Attribute_Kind_Of (Current_Attribute) /= Single
|
Attribute_Kind_Of (Current_Attribute) /= Single
|
then
|
then
|
if Attribute_Kind_Of (Current_Attribute) = Unknown then
|
if Attribute_Kind_Of (Current_Attribute) = Unknown then
|
Set_Attribute_Kind_Of (Current_Attribute, To => Single);
|
Set_Attribute_Kind_Of (Current_Attribute, To => Single);
|
|
|
else
|
else
|
Full_Associative_Array := True;
|
Full_Associative_Array := True;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Expect (Tok_Use, "USE");
|
Expect (Tok_Use, "USE");
|
|
|
if Token = Tok_Use then
|
if Token = Tok_Use then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
if Full_Associative_Array then
|
if Full_Associative_Array then
|
|
|
-- Expect <project>'<same_attribute_name>, or
|
-- Expect <project>'<same_attribute_name>, or
|
-- <project>.<same_package_name>'<same_attribute_name>
|
-- <project>.<same_package_name>'<same_attribute_name>
|
|
|
declare
|
declare
|
The_Project : Project_Node_Id := Empty_Node;
|
The_Project : Project_Node_Id := Empty_Node;
|
-- The node of the project where the associative array is
|
-- The node of the project where the associative array is
|
-- declared.
|
-- declared.
|
|
|
The_Package : Project_Node_Id := Empty_Node;
|
The_Package : Project_Node_Id := Empty_Node;
|
-- The node of the package where the associative array is
|
-- The node of the package where the associative array is
|
-- declared, if any.
|
-- declared, if any.
|
|
|
Project_Name : Name_Id := No_Name;
|
Project_Name : Name_Id := No_Name;
|
-- The name of the project where the associative array is
|
-- The name of the project where the associative array is
|
-- declared.
|
-- declared.
|
|
|
Location : Source_Ptr := No_Location;
|
Location : Source_Ptr := No_Location;
|
-- The location of the project name
|
-- The location of the project name
|
|
|
begin
|
begin
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
Location := Token_Ptr;
|
Location := Token_Ptr;
|
|
|
-- Find the project node in the imported project or
|
-- Find the project node in the imported project or
|
-- in the project being extended.
|
-- in the project being extended.
|
|
|
The_Project := Imported_Or_Extended_Project_Of
|
The_Project := Imported_Or_Extended_Project_Of
|
(Current_Project, In_Tree, Token_Name);
|
(Current_Project, In_Tree, Token_Name);
|
|
|
if No (The_Project) then
|
if No (The_Project) then
|
Error_Msg (Flags, "unknown project", Location);
|
Error_Msg (Flags, "unknown project", Location);
|
Scan (In_Tree); -- past the project name
|
Scan (In_Tree); -- past the project name
|
|
|
else
|
else
|
Project_Name := Token_Name;
|
Project_Name := Token_Name;
|
Scan (In_Tree); -- past the project name
|
Scan (In_Tree); -- past the project name
|
|
|
-- If this is inside a package, a dot followed by the
|
-- If this is inside a package, a dot followed by the
|
-- name of the package must followed the project name.
|
-- name of the package must followed the project name.
|
|
|
if Present (Current_Package) then
|
if Present (Current_Package) then
|
Expect (Tok_Dot, "`.`");
|
Expect (Tok_Dot, "`.`");
|
|
|
if Token /= Tok_Dot then
|
if Token /= Tok_Dot then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
|
|
else
|
else
|
Scan (In_Tree); -- past the dot
|
Scan (In_Tree); -- past the dot
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token /= Tok_Identifier then
|
if Token /= Tok_Identifier then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
|
|
-- If it is not the same package name, issue error
|
-- If it is not the same package name, issue error
|
|
|
elsif
|
elsif
|
Token_Name /= Name_Of (Current_Package, In_Tree)
|
Token_Name /= Name_Of (Current_Package, In_Tree)
|
then
|
then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
Error_Msg
|
Error_Msg
|
(Flags, "not the same package as " &
|
(Flags, "not the same package as " &
|
Get_Name_String
|
Get_Name_String
|
(Name_Of (Current_Package, In_Tree)),
|
(Name_Of (Current_Package, In_Tree)),
|
Token_Ptr);
|
Token_Ptr);
|
|
|
else
|
else
|
The_Package :=
|
The_Package :=
|
First_Package_Of (The_Project, In_Tree);
|
First_Package_Of (The_Project, In_Tree);
|
|
|
-- Look for the package node
|
-- Look for the package node
|
|
|
while Present (The_Package)
|
while Present (The_Package)
|
and then
|
and then
|
Name_Of (The_Package, In_Tree) /= Token_Name
|
Name_Of (The_Package, In_Tree) /= Token_Name
|
loop
|
loop
|
The_Package :=
|
The_Package :=
|
Next_Package_In_Project
|
Next_Package_In_Project
|
(The_Package, In_Tree);
|
(The_Package, In_Tree);
|
end loop;
|
end loop;
|
|
|
-- If the package cannot be found in the
|
-- If the package cannot be found in the
|
-- project, issue an error.
|
-- project, issue an error.
|
|
|
if No (The_Package) then
|
if No (The_Package) then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
Error_Msg_Name_2 := Project_Name;
|
Error_Msg_Name_2 := Project_Name;
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg_Name_1 := Token_Name;
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"package % not declared in project %",
|
"package % not declared in project %",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
|
|
Scan (In_Tree); -- past the package name
|
Scan (In_Tree); -- past the package name
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if Present (The_Project) then
|
if Present (The_Project) then
|
|
|
-- Looking for '<same attribute name>
|
-- Looking for '<same attribute name>
|
|
|
Expect (Tok_Apostrophe, "`''`");
|
Expect (Tok_Apostrophe, "`''`");
|
|
|
if Token /= Tok_Apostrophe then
|
if Token /= Tok_Apostrophe then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
|
|
else
|
else
|
Scan (In_Tree); -- past the apostrophe
|
Scan (In_Tree); -- past the apostrophe
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token /= Tok_Identifier then
|
if Token /= Tok_Identifier then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
|
|
else
|
else
|
-- If it is not the same attribute name, issue error
|
-- If it is not the same attribute name, issue error
|
|
|
if Token_Name /= Attribute_Name then
|
if Token_Name /= Attribute_Name then
|
The_Project := Empty_Node;
|
The_Project := Empty_Node;
|
Error_Msg_Name_1 := Attribute_Name;
|
Error_Msg_Name_1 := Attribute_Name;
|
Error_Msg
|
Error_Msg
|
(Flags, "invalid name, should be %", Token_Ptr);
|
(Flags, "invalid name, should be %", Token_Ptr);
|
end if;
|
end if;
|
|
|
Scan (In_Tree); -- past the attribute name
|
Scan (In_Tree); -- past the attribute name
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if No (The_Project) then
|
if No (The_Project) then
|
|
|
-- If there were any problem, set the attribute id to null,
|
-- If there were any problem, set the attribute id to null,
|
-- so that the node will not be recorded.
|
-- so that the node will not be recorded.
|
|
|
Current_Attribute := Empty_Attribute;
|
Current_Attribute := Empty_Attribute;
|
|
|
else
|
else
|
-- Set the appropriate field in the node.
|
-- Set the appropriate field in the node.
|
-- Note that the index and the expression are nil. This
|
-- Note that the index and the expression are nil. This
|
-- characterizes full associative array attribute
|
-- characterizes full associative array attribute
|
-- declarations.
|
-- declarations.
|
|
|
Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
|
Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
|
Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
|
Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
|
end if;
|
end if;
|
end;
|
end;
|
|
|
-- Other attribute declarations (not full associative array)
|
-- Other attribute declarations (not full associative array)
|
|
|
else
|
else
|
declare
|
declare
|
Expression_Location : constant Source_Ptr := Token_Ptr;
|
Expression_Location : constant Source_Ptr := Token_Ptr;
|
-- The location of the first token of the expression
|
-- The location of the first token of the expression
|
|
|
Expression : Project_Node_Id := Empty_Node;
|
Expression : Project_Node_Id := Empty_Node;
|
-- The expression, value for the attribute declaration
|
-- The expression, value for the attribute declaration
|
|
|
begin
|
begin
|
-- Get the expression value and set it in the attribute node
|
-- Get the expression value and set it in the attribute node
|
|
|
Parse_Expression
|
Parse_Expression
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Expression => Expression,
|
Expression => Expression,
|
Flags => Flags,
|
Flags => Flags,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Optional_Index => Optional_Index);
|
Optional_Index => Optional_Index);
|
Set_Expression_Of (Attribute, In_Tree, To => Expression);
|
Set_Expression_Of (Attribute, In_Tree, To => Expression);
|
|
|
-- If the expression is legal, but not of the right kind
|
-- If the expression is legal, but not of the right kind
|
-- for the attribute, issue an error.
|
-- for the attribute, issue an error.
|
|
|
if Current_Attribute /= Empty_Attribute
|
if Current_Attribute /= Empty_Attribute
|
and then Present (Expression)
|
and then Present (Expression)
|
and then Variable_Kind_Of (Current_Attribute) /=
|
and then Variable_Kind_Of (Current_Attribute) /=
|
Expression_Kind_Of (Expression, In_Tree)
|
Expression_Kind_Of (Expression, In_Tree)
|
then
|
then
|
if Variable_Kind_Of (Current_Attribute) = Undefined then
|
if Variable_Kind_Of (Current_Attribute) = Undefined then
|
Set_Variable_Kind_Of
|
Set_Variable_Kind_Of
|
(Current_Attribute,
|
(Current_Attribute,
|
To => Expression_Kind_Of (Expression, In_Tree));
|
To => Expression_Kind_Of (Expression, In_Tree));
|
|
|
else
|
else
|
Error_Msg
|
Error_Msg
|
(Flags, "wrong expression kind for attribute """ &
|
(Flags, "wrong expression kind for attribute """ &
|
Get_Name_String
|
Get_Name_String
|
(Attribute_Name_Of (Current_Attribute)) &
|
(Attribute_Name_Of (Current_Attribute)) &
|
"""",
|
"""",
|
Expression_Location);
|
Expression_Location);
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- If the attribute was not recognized, return an empty node.
|
-- 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
|
-- It may be that it is not in a package to check, and the node will
|
-- not be added to the tree.
|
-- not be added to the tree.
|
|
|
if Current_Attribute = Empty_Attribute then
|
if Current_Attribute = Empty_Attribute then
|
Attribute := Empty_Node;
|
Attribute := Empty_Node;
|
end if;
|
end if;
|
|
|
Set_End_Of_Line (Attribute);
|
Set_End_Of_Line (Attribute);
|
Set_Previous_Line_Node (Attribute);
|
Set_Previous_Line_Node (Attribute);
|
end Parse_Attribute_Declaration;
|
end Parse_Attribute_Declaration;
|
|
|
-----------------------------
|
-----------------------------
|
-- Parse_Case_Construction --
|
-- Parse_Case_Construction --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Parse_Case_Construction
|
procedure Parse_Case_Construction
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Case_Construction : out Project_Node_Id;
|
Case_Construction : out Project_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Current_Item : Project_Node_Id := Empty_Node;
|
Current_Item : Project_Node_Id := Empty_Node;
|
Next_Item : Project_Node_Id := Empty_Node;
|
Next_Item : Project_Node_Id := Empty_Node;
|
First_Case_Item : Boolean := True;
|
First_Case_Item : Boolean := True;
|
|
|
Variable_Location : Source_Ptr := No_Location;
|
Variable_Location : Source_Ptr := No_Location;
|
|
|
String_Type : Project_Node_Id := Empty_Node;
|
String_Type : Project_Node_Id := Empty_Node;
|
|
|
Case_Variable : Project_Node_Id := Empty_Node;
|
Case_Variable : Project_Node_Id := Empty_Node;
|
|
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
|
|
First_Choice : Project_Node_Id := Empty_Node;
|
First_Choice : Project_Node_Id := Empty_Node;
|
|
|
When_Others : Boolean := False;
|
When_Others : Boolean := False;
|
-- Set to True when there is a "when others =>" clause
|
-- Set to True when there is a "when others =>" clause
|
|
|
begin
|
begin
|
Case_Construction :=
|
Case_Construction :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Case_Construction, In_Tree => In_Tree);
|
(Of_Kind => N_Case_Construction, In_Tree => In_Tree);
|
Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
|
|
|
-- Scan past "case"
|
-- Scan past "case"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
-- Get the switch variable
|
-- Get the switch variable
|
|
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
Variable_Location := Token_Ptr;
|
Variable_Location := Token_Ptr;
|
Parse_Variable_Reference
|
Parse_Variable_Reference
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Variable => Case_Variable,
|
Variable => Case_Variable,
|
Flags => Flags,
|
Flags => Flags,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package);
|
Current_Package => Current_Package);
|
Set_Case_Variable_Reference_Of
|
Set_Case_Variable_Reference_Of
|
(Case_Construction, In_Tree, To => Case_Variable);
|
(Case_Construction, In_Tree, To => Case_Variable);
|
|
|
else
|
else
|
if Token /= Tok_Is then
|
if Token /= Tok_Is then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if Present (Case_Variable) then
|
if Present (Case_Variable) then
|
String_Type := String_Type_Of (Case_Variable, In_Tree);
|
String_Type := String_Type_Of (Case_Variable, In_Tree);
|
|
|
if No (String_Type) then
|
if No (String_Type) then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"variable """ &
|
"variable """ &
|
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
|
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
|
""" is not typed",
|
""" is not typed",
|
Variable_Location);
|
Variable_Location);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Expect (Tok_Is, "IS");
|
Expect (Tok_Is, "IS");
|
|
|
if Token = Tok_Is then
|
if Token = Tok_Is then
|
Set_End_Of_Line (Case_Construction);
|
Set_End_Of_Line (Case_Construction);
|
Set_Previous_Line_Node (Case_Construction);
|
Set_Previous_Line_Node (Case_Construction);
|
Set_Next_End_Node (Case_Construction);
|
Set_Next_End_Node (Case_Construction);
|
|
|
-- Scan past "is"
|
-- Scan past "is"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Start_New_Case_Construction (In_Tree, String_Type);
|
Start_New_Case_Construction (In_Tree, String_Type);
|
|
|
When_Loop :
|
When_Loop :
|
|
|
while Token = Tok_When loop
|
while Token = Tok_When loop
|
|
|
if First_Case_Item then
|
if First_Case_Item then
|
Current_Item :=
|
Current_Item :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
|
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
|
Set_First_Case_Item_Of
|
Set_First_Case_Item_Of
|
(Case_Construction, In_Tree, To => Current_Item);
|
(Case_Construction, In_Tree, To => Current_Item);
|
First_Case_Item := False;
|
First_Case_Item := False;
|
|
|
else
|
else
|
Next_Item :=
|
Next_Item :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
|
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
|
Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
|
Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
|
Current_Item := Next_Item;
|
Current_Item := Next_Item;
|
end if;
|
end if;
|
|
|
Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
|
|
|
-- Scan past "when"
|
-- Scan past "when"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
if Token = Tok_Others then
|
if Token = Tok_Others then
|
When_Others := True;
|
When_Others := True;
|
|
|
-- Scan past "others"
|
-- Scan past "others"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Expect (Tok_Arrow, "`=>`");
|
Expect (Tok_Arrow, "`=>`");
|
Set_End_Of_Line (Current_Item);
|
Set_End_Of_Line (Current_Item);
|
Set_Previous_Line_Node (Current_Item);
|
Set_Previous_Line_Node (Current_Item);
|
|
|
-- Empty_Node in Field1 of a Case_Item indicates
|
-- Empty_Node in Field1 of a Case_Item indicates
|
-- the "when others =>" branch.
|
-- the "when others =>" branch.
|
|
|
Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
|
Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
|
|
|
Parse_Declarative_Items
|
Parse_Declarative_Items
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Declarations => First_Declarative_Item,
|
Declarations => First_Declarative_Item,
|
In_Zone => In_Case_Construction,
|
In_Zone => In_Case_Construction,
|
First_Attribute => First_Attribute,
|
First_Attribute => First_Attribute,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
-- "when others =>" must be the last branch, so save the
|
-- "when others =>" must be the last branch, so save the
|
-- Case_Item and exit
|
-- Case_Item and exit
|
|
|
Set_First_Declarative_Item_Of
|
Set_First_Declarative_Item_Of
|
(Current_Item, In_Tree, To => First_Declarative_Item);
|
(Current_Item, In_Tree, To => First_Declarative_Item);
|
exit When_Loop;
|
exit When_Loop;
|
|
|
else
|
else
|
Parse_Choice_List
|
Parse_Choice_List
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
First_Choice => First_Choice,
|
First_Choice => First_Choice,
|
Flags => Flags);
|
Flags => Flags);
|
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
|
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
|
|
|
Expect (Tok_Arrow, "`=>`");
|
Expect (Tok_Arrow, "`=>`");
|
Set_End_Of_Line (Current_Item);
|
Set_End_Of_Line (Current_Item);
|
Set_Previous_Line_Node (Current_Item);
|
Set_Previous_Line_Node (Current_Item);
|
|
|
Parse_Declarative_Items
|
Parse_Declarative_Items
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Declarations => First_Declarative_Item,
|
Declarations => First_Declarative_Item,
|
In_Zone => In_Case_Construction,
|
In_Zone => In_Case_Construction,
|
First_Attribute => First_Attribute,
|
First_Attribute => First_Attribute,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_First_Declarative_Item_Of
|
Set_First_Declarative_Item_Of
|
(Current_Item, In_Tree, To => First_Declarative_Item);
|
(Current_Item, In_Tree, To => First_Declarative_Item);
|
|
|
end if;
|
end if;
|
end loop When_Loop;
|
end loop When_Loop;
|
|
|
End_Case_Construction
|
End_Case_Construction
|
(Check_All_Labels => not When_Others and not Quiet_Output,
|
(Check_All_Labels => not When_Others and not Quiet_Output,
|
Case_Location => Location_Of (Case_Construction, In_Tree),
|
Case_Location => Location_Of (Case_Construction, In_Tree),
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Expect (Tok_End, "`END CASE`");
|
Expect (Tok_End, "`END CASE`");
|
Remove_Next_End_Node;
|
Remove_Next_End_Node;
|
|
|
if Token = Tok_End then
|
if Token = Tok_End then
|
|
|
-- Scan past "end"
|
-- Scan past "end"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Expect (Tok_Case, "CASE");
|
Expect (Tok_Case, "CASE");
|
|
|
end if;
|
end if;
|
|
|
-- Scan past "case"
|
-- Scan past "case"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Expect (Tok_Semicolon, "`;`");
|
Expect (Tok_Semicolon, "`;`");
|
Set_Previous_End_Node (Case_Construction);
|
Set_Previous_End_Node (Case_Construction);
|
|
|
end Parse_Case_Construction;
|
end Parse_Case_Construction;
|
|
|
-----------------------------
|
-----------------------------
|
-- Parse_Declarative_Items --
|
-- Parse_Declarative_Items --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Parse_Declarative_Items
|
procedure Parse_Declarative_Items
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Declarations : out Project_Node_Id;
|
Declarations : out Project_Node_Id;
|
In_Zone : Zone;
|
In_Zone : Zone;
|
First_Attribute : Attribute_Node_Id;
|
First_Attribute : Attribute_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Current_Declarative_Item : Project_Node_Id := Empty_Node;
|
Current_Declarative_Item : Project_Node_Id := Empty_Node;
|
Next_Declarative_Item : Project_Node_Id := Empty_Node;
|
Next_Declarative_Item : Project_Node_Id := Empty_Node;
|
Current_Declaration : Project_Node_Id := Empty_Node;
|
Current_Declaration : Project_Node_Id := Empty_Node;
|
Item_Location : Source_Ptr := No_Location;
|
Item_Location : Source_Ptr := No_Location;
|
|
|
begin
|
begin
|
Declarations := Empty_Node;
|
Declarations := Empty_Node;
|
|
|
loop
|
loop
|
-- We are always positioned at the token that precedes the first
|
-- We are always positioned at the token that precedes the first
|
-- token of the declarative element. Scan past it.
|
-- token of the declarative element. Scan past it.
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Item_Location := Token_Ptr;
|
Item_Location := Token_Ptr;
|
|
|
case Token is
|
case Token is
|
when Tok_Identifier =>
|
when Tok_Identifier =>
|
|
|
if In_Zone = In_Case_Construction then
|
if In_Zone = In_Case_Construction then
|
|
|
-- Check if the variable has already been declared
|
-- Check if the variable has already been declared
|
|
|
declare
|
declare
|
The_Variable : Project_Node_Id := Empty_Node;
|
The_Variable : Project_Node_Id := Empty_Node;
|
|
|
begin
|
begin
|
if Present (Current_Package) then
|
if Present (Current_Package) then
|
The_Variable :=
|
The_Variable :=
|
First_Variable_Of (Current_Package, In_Tree);
|
First_Variable_Of (Current_Package, In_Tree);
|
elsif Present (Current_Project) then
|
elsif Present (Current_Project) then
|
The_Variable :=
|
The_Variable :=
|
First_Variable_Of (Current_Project, In_Tree);
|
First_Variable_Of (Current_Project, In_Tree);
|
end if;
|
end if;
|
|
|
while Present (The_Variable)
|
while Present (The_Variable)
|
and then Name_Of (The_Variable, In_Tree) /=
|
and then Name_Of (The_Variable, In_Tree) /=
|
Token_Name
|
Token_Name
|
loop
|
loop
|
The_Variable := Next_Variable (The_Variable, In_Tree);
|
The_Variable := Next_Variable (The_Variable, In_Tree);
|
end loop;
|
end loop;
|
|
|
-- It is an error to declare a variable in a case
|
-- It is an error to declare a variable in a case
|
-- construction for the first time.
|
-- construction for the first time.
|
|
|
if No (The_Variable) then
|
if No (The_Variable) then
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"a variable cannot be declared " &
|
"a variable cannot be declared " &
|
"for the first time here",
|
"for the first time here",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
Parse_Variable_Declaration
|
Parse_Variable_Declaration
|
(In_Tree,
|
(In_Tree,
|
Current_Declaration,
|
Current_Declaration,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_End_Of_Line (Current_Declaration);
|
Set_End_Of_Line (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
|
|
when Tok_For =>
|
when Tok_For =>
|
|
|
Parse_Attribute_Declaration
|
Parse_Attribute_Declaration
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Attribute => Current_Declaration,
|
Attribute => Current_Declaration,
|
First_Attribute => First_Attribute,
|
First_Attribute => First_Attribute,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_End_Of_Line (Current_Declaration);
|
Set_End_Of_Line (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
|
|
when Tok_Null =>
|
when Tok_Null =>
|
|
|
Scan (In_Tree); -- past "null"
|
Scan (In_Tree); -- past "null"
|
|
|
when Tok_Package =>
|
when Tok_Package =>
|
|
|
-- Package declaration
|
-- Package declaration
|
|
|
if In_Zone /= In_Project then
|
if In_Zone /= In_Project then
|
Error_Msg
|
Error_Msg
|
(Flags, "a package cannot be declared here", Token_Ptr);
|
(Flags, "a package cannot be declared here", Token_Ptr);
|
end if;
|
end if;
|
|
|
Parse_Package_Declaration
|
Parse_Package_Declaration
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Package_Declaration => Current_Declaration,
|
Package_Declaration => Current_Declaration,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_Previous_End_Node (Current_Declaration);
|
Set_Previous_End_Node (Current_Declaration);
|
|
|
when Tok_Type =>
|
when Tok_Type =>
|
|
|
-- Type String Declaration
|
-- Type String Declaration
|
|
|
if In_Zone /= In_Project then
|
if In_Zone /= In_Project then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"a string type cannot be declared here",
|
"a string type cannot be declared here",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
|
|
Parse_String_Type_Declaration
|
Parse_String_Type_Declaration
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
String_Type => Current_Declaration,
|
String_Type => Current_Declaration,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_End_Of_Line (Current_Declaration);
|
Set_End_Of_Line (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
Set_Previous_Line_Node (Current_Declaration);
|
|
|
when Tok_Case =>
|
when Tok_Case =>
|
|
|
-- Case construction
|
-- Case construction
|
|
|
Parse_Case_Construction
|
Parse_Case_Construction
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Case_Construction => Current_Declaration,
|
Case_Construction => Current_Declaration,
|
First_Attribute => First_Attribute,
|
First_Attribute => First_Attribute,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_Previous_End_Node (Current_Declaration);
|
Set_Previous_End_Node (Current_Declaration);
|
|
|
when others =>
|
when others =>
|
exit;
|
exit;
|
|
|
-- We are leaving Parse_Declarative_Items positioned
|
-- We are leaving Parse_Declarative_Items positioned
|
-- at the first token after the list of declarative items.
|
-- at the first token after the list of declarative items.
|
-- It could be "end" (for a project, a package declaration or
|
-- It could be "end" (for a project, a package declaration or
|
-- a case construction) or "when" (for a case construction)
|
-- a case construction) or "when" (for a case construction)
|
|
|
end case;
|
end case;
|
|
|
Expect (Tok_Semicolon, "`;` after declarative items");
|
Expect (Tok_Semicolon, "`;` after declarative items");
|
|
|
-- Insert an N_Declarative_Item in the tree, but only if
|
-- Insert an N_Declarative_Item in the tree, but only if
|
-- Current_Declaration is not an empty node.
|
-- Current_Declaration is not an empty node.
|
|
|
if Present (Current_Declaration) then
|
if Present (Current_Declaration) then
|
if No (Current_Declarative_Item) then
|
if No (Current_Declarative_Item) then
|
Current_Declarative_Item :=
|
Current_Declarative_Item :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
|
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
|
Declarations := Current_Declarative_Item;
|
Declarations := Current_Declarative_Item;
|
|
|
else
|
else
|
Next_Declarative_Item :=
|
Next_Declarative_Item :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
|
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
|
Set_Next_Declarative_Item
|
Set_Next_Declarative_Item
|
(Current_Declarative_Item, In_Tree,
|
(Current_Declarative_Item, In_Tree,
|
To => Next_Declarative_Item);
|
To => Next_Declarative_Item);
|
Current_Declarative_Item := Next_Declarative_Item;
|
Current_Declarative_Item := Next_Declarative_Item;
|
end if;
|
end if;
|
|
|
Set_Current_Item_Node
|
Set_Current_Item_Node
|
(Current_Declarative_Item, In_Tree,
|
(Current_Declarative_Item, In_Tree,
|
To => Current_Declaration);
|
To => Current_Declaration);
|
Set_Location_Of
|
Set_Location_Of
|
(Current_Declarative_Item, In_Tree, To => Item_Location);
|
(Current_Declarative_Item, In_Tree, To => Item_Location);
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Parse_Declarative_Items;
|
end Parse_Declarative_Items;
|
|
|
-------------------------------
|
-------------------------------
|
-- Parse_Package_Declaration --
|
-- Parse_Package_Declaration --
|
-------------------------------
|
-------------------------------
|
|
|
procedure Parse_Package_Declaration
|
procedure Parse_Package_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Package_Declaration : out Project_Node_Id;
|
Package_Declaration : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Packages_To_Check : String_List_Access;
|
Packages_To_Check : String_List_Access;
|
Is_Config_File : Boolean;
|
Is_Config_File : Boolean;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
First_Attribute : Attribute_Node_Id := Empty_Attribute;
|
First_Attribute : Attribute_Node_Id := Empty_Attribute;
|
Current_Package : Package_Node_Id := Empty_Package;
|
Current_Package : Package_Node_Id := Empty_Package;
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
First_Declarative_Item : Project_Node_Id := Empty_Node;
|
Package_Location : constant Source_Ptr := Token_Ptr;
|
Package_Location : constant Source_Ptr := Token_Ptr;
|
Renaming : Boolean := False;
|
Renaming : Boolean := False;
|
Extending : Boolean := False;
|
Extending : Boolean := False;
|
|
|
begin
|
begin
|
Package_Declaration :=
|
Package_Declaration :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
|
(Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
|
Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
|
Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
|
|
|
-- Scan past "package"
|
-- Scan past "package"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
|
Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
|
|
|
Current_Package := Package_Node_Id_Of (Token_Name);
|
Current_Package := Package_Node_Id_Of (Token_Name);
|
|
|
if Current_Package = Empty_Package then
|
if Current_Package = Empty_Package then
|
if not Quiet_Output then
|
if not Quiet_Output then
|
declare
|
declare
|
List : constant Strings.String_List := Package_Name_List;
|
List : constant Strings.String_List := Package_Name_List;
|
Index : Natural;
|
Index : Natural;
|
Name : constant String := Get_Name_String (Token_Name);
|
Name : constant String := Get_Name_String (Token_Name);
|
|
|
begin
|
begin
|
-- Check for possible misspelling of a known package name
|
-- Check for possible misspelling of a known package name
|
|
|
Index := 0;
|
Index := 0;
|
loop
|
loop
|
if Index >= List'Last then
|
if Index >= List'Last then
|
Index := 0;
|
Index := 0;
|
exit;
|
exit;
|
end if;
|
end if;
|
|
|
Index := Index + 1;
|
Index := Index + 1;
|
exit when
|
exit when
|
GNAT.Spelling_Checker.Is_Bad_Spelling_Of
|
GNAT.Spelling_Checker.Is_Bad_Spelling_Of
|
(Name, List (Index).all);
|
(Name, List (Index).all);
|
end loop;
|
end loop;
|
|
|
-- Issue warning(s) in verbose mode or when a possible
|
-- Issue warning(s) in verbose mode or when a possible
|
-- misspelling has been found.
|
-- misspelling has been found.
|
|
|
if Verbose_Mode or else Index /= 0 then
|
if Verbose_Mode or else Index /= 0 then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"?""" &
|
"?""" &
|
Get_Name_String
|
Get_Name_String
|
(Name_Of (Package_Declaration, In_Tree)) &
|
(Name_Of (Package_Declaration, In_Tree)) &
|
""" is not a known package name",
|
""" is not a known package name",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
|
|
if Index /= 0 then
|
if Index /= 0 then
|
Error_Msg -- CODEFIX
|
Error_Msg -- CODEFIX
|
(Flags,
|
(Flags,
|
"\?possible misspelling of """ &
|
"\?possible misspelling of """ &
|
List (Index).all & """", Token_Ptr);
|
List (Index).all & """", Token_Ptr);
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
-- Set the package declaration to "ignored" so that it is not
|
-- Set the package declaration to "ignored" so that it is not
|
-- processed by Prj.Proc.Process.
|
-- processed by Prj.Proc.Process.
|
|
|
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
|
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
|
|
|
-- Add the unknown package in the list of packages
|
-- Add the unknown package in the list of packages
|
|
|
Add_Unknown_Package (Token_Name, Current_Package);
|
Add_Unknown_Package (Token_Name, Current_Package);
|
|
|
elsif Current_Package = Unknown_Package then
|
elsif Current_Package = Unknown_Package then
|
|
|
-- Set the package declaration to "ignored" so that it is not
|
-- Set the package declaration to "ignored" so that it is not
|
-- processed by Prj.Proc.Process.
|
-- processed by Prj.Proc.Process.
|
|
|
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
|
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
|
|
|
else
|
else
|
First_Attribute := First_Attribute_Of (Current_Package);
|
First_Attribute := First_Attribute_Of (Current_Package);
|
end if;
|
end if;
|
|
|
Set_Package_Id_Of
|
Set_Package_Id_Of
|
(Package_Declaration, In_Tree, To => Current_Package);
|
(Package_Declaration, In_Tree, To => Current_Package);
|
|
|
declare
|
declare
|
Current : Project_Node_Id :=
|
Current : Project_Node_Id :=
|
First_Package_Of (Current_Project, In_Tree);
|
First_Package_Of (Current_Project, In_Tree);
|
|
|
begin
|
begin
|
while Present (Current)
|
while Present (Current)
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
loop
|
loop
|
Current := Next_Package_In_Project (Current, In_Tree);
|
Current := Next_Package_In_Project (Current, In_Tree);
|
end loop;
|
end loop;
|
|
|
if Present (Current) then
|
if Present (Current) then
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"package """ &
|
"package """ &
|
Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
|
Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
|
""" is declared twice in the same project",
|
""" is declared twice in the same project",
|
Token_Ptr);
|
Token_Ptr);
|
|
|
else
|
else
|
-- Add the package to the project list
|
-- Add the package to the project list
|
|
|
Set_Next_Package_In_Project
|
Set_Next_Package_In_Project
|
(Package_Declaration, In_Tree,
|
(Package_Declaration, In_Tree,
|
To => First_Package_Of (Current_Project, In_Tree));
|
To => First_Package_Of (Current_Project, In_Tree));
|
Set_First_Package_Of
|
Set_First_Package_Of
|
(Current_Project, In_Tree, To => Package_Declaration);
|
(Current_Project, In_Tree, To => Package_Declaration);
|
end if;
|
end if;
|
end;
|
end;
|
|
|
-- Scan past the package name
|
-- Scan past the package name
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Check_Package_Allowed
|
Check_Package_Allowed
|
(In_Tree, Current_Project, Package_Declaration, Flags);
|
(In_Tree, Current_Project, Package_Declaration, Flags);
|
|
|
if Token = Tok_Renames then
|
if Token = Tok_Renames then
|
Renaming := True;
|
Renaming := True;
|
elsif Token = Tok_Extends then
|
elsif Token = Tok_Extends then
|
Extending := True;
|
Extending := True;
|
end if;
|
end if;
|
|
|
if Renaming or else Extending then
|
if Renaming or else Extending then
|
if Is_Config_File then
|
if Is_Config_File then
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"no package rename or extension in configuration projects",
|
"no package rename or extension in configuration projects",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
|
|
-- Scan past "renames" or "extends"
|
-- Scan past "renames" or "extends"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
declare
|
declare
|
Project_Name : constant Name_Id := Token_Name;
|
Project_Name : constant Name_Id := Token_Name;
|
|
|
Clause : Project_Node_Id :=
|
Clause : Project_Node_Id :=
|
First_With_Clause_Of (Current_Project, In_Tree);
|
First_With_Clause_Of (Current_Project, In_Tree);
|
The_Project : Project_Node_Id := Empty_Node;
|
The_Project : Project_Node_Id := Empty_Node;
|
Extended : constant Project_Node_Id :=
|
Extended : constant Project_Node_Id :=
|
Extended_Project_Of
|
Extended_Project_Of
|
(Project_Declaration_Of
|
(Project_Declaration_Of
|
(Current_Project, In_Tree),
|
(Current_Project, In_Tree),
|
In_Tree);
|
In_Tree);
|
begin
|
begin
|
while Present (Clause) loop
|
while Present (Clause) loop
|
-- Only non limited imported projects may be used in a
|
-- Only non limited imported projects may be used in a
|
-- renames declaration.
|
-- renames declaration.
|
|
|
The_Project :=
|
The_Project :=
|
Non_Limited_Project_Node_Of (Clause, In_Tree);
|
Non_Limited_Project_Node_Of (Clause, In_Tree);
|
exit when Present (The_Project)
|
exit when Present (The_Project)
|
and then Name_Of (The_Project, In_Tree) = Project_Name;
|
and then Name_Of (The_Project, In_Tree) = Project_Name;
|
Clause := Next_With_Clause_Of (Clause, In_Tree);
|
Clause := Next_With_Clause_Of (Clause, In_Tree);
|
end loop;
|
end loop;
|
|
|
if No (Clause) then
|
if No (Clause) then
|
-- As we have not found the project in the imports, we check
|
-- As we have not found the project in the imports, we check
|
-- if it's the name of an eventual extended project.
|
-- if it's the name of an eventual extended project.
|
|
|
if Present (Extended)
|
if Present (Extended)
|
and then Name_Of (Extended, In_Tree) = Project_Name
|
and then Name_Of (Extended, In_Tree) = Project_Name
|
then
|
then
|
Set_Project_Of_Renamed_Package_Of
|
Set_Project_Of_Renamed_Package_Of
|
(Package_Declaration, In_Tree, To => Extended);
|
(Package_Declaration, In_Tree, To => Extended);
|
else
|
else
|
Error_Msg_Name_1 := Project_Name;
|
Error_Msg_Name_1 := Project_Name;
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"% is not an imported or extended project", Token_Ptr);
|
"% is not an imported or extended project", Token_Ptr);
|
end if;
|
end if;
|
else
|
else
|
Set_Project_Of_Renamed_Package_Of
|
Set_Project_Of_Renamed_Package_Of
|
(Package_Declaration, In_Tree, To => The_Project);
|
(Package_Declaration, In_Tree, To => The_Project);
|
end if;
|
end if;
|
end;
|
end;
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Expect (Tok_Dot, "`.`");
|
Expect (Tok_Dot, "`.`");
|
|
|
if Token = Tok_Dot then
|
if Token = Tok_Dot then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
|
if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
|
Error_Msg (Flags, "not the same package name", Token_Ptr);
|
Error_Msg (Flags, "not the same package name", Token_Ptr);
|
elsif
|
elsif
|
Present (Project_Of_Renamed_Package_Of
|
Present (Project_Of_Renamed_Package_Of
|
(Package_Declaration, In_Tree))
|
(Package_Declaration, In_Tree))
|
then
|
then
|
declare
|
declare
|
Current : Project_Node_Id :=
|
Current : Project_Node_Id :=
|
First_Package_Of
|
First_Package_Of
|
(Project_Of_Renamed_Package_Of
|
(Project_Of_Renamed_Package_Of
|
(Package_Declaration, In_Tree),
|
(Package_Declaration, In_Tree),
|
In_Tree);
|
In_Tree);
|
|
|
begin
|
begin
|
while Present (Current)
|
while Present (Current)
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
loop
|
loop
|
Current :=
|
Current :=
|
Next_Package_In_Project (Current, In_Tree);
|
Next_Package_In_Project (Current, In_Tree);
|
end loop;
|
end loop;
|
|
|
if No (Current) then
|
if No (Current) then
|
Error_Msg
|
Error_Msg
|
(Flags, """" &
|
(Flags, """" &
|
Get_Name_String (Token_Name) &
|
Get_Name_String (Token_Name) &
|
""" is not a package declared by the project",
|
""" is not a package declared by the project",
|
Token_Ptr);
|
Token_Ptr);
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if Renaming then
|
if Renaming then
|
Expect (Tok_Semicolon, "`;`");
|
Expect (Tok_Semicolon, "`;`");
|
Set_End_Of_Line (Package_Declaration);
|
Set_End_Of_Line (Package_Declaration);
|
Set_Previous_Line_Node (Package_Declaration);
|
Set_Previous_Line_Node (Package_Declaration);
|
|
|
elsif Token = Tok_Is then
|
elsif Token = Tok_Is then
|
Set_End_Of_Line (Package_Declaration);
|
Set_End_Of_Line (Package_Declaration);
|
Set_Previous_Line_Node (Package_Declaration);
|
Set_Previous_Line_Node (Package_Declaration);
|
Set_Next_End_Node (Package_Declaration);
|
Set_Next_End_Node (Package_Declaration);
|
|
|
Parse_Declarative_Items
|
Parse_Declarative_Items
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Declarations => First_Declarative_Item,
|
Declarations => First_Declarative_Item,
|
In_Zone => In_Package,
|
In_Zone => In_Package,
|
First_Attribute => First_Attribute,
|
First_Attribute => First_Attribute,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Package_Declaration,
|
Current_Package => Package_Declaration,
|
Packages_To_Check => Packages_To_Check,
|
Packages_To_Check => Packages_To_Check,
|
Is_Config_File => Is_Config_File,
|
Is_Config_File => Is_Config_File,
|
Flags => Flags);
|
Flags => Flags);
|
|
|
Set_First_Declarative_Item_Of
|
Set_First_Declarative_Item_Of
|
(Package_Declaration, In_Tree, To => First_Declarative_Item);
|
(Package_Declaration, In_Tree, To => First_Declarative_Item);
|
|
|
Expect (Tok_End, "END");
|
Expect (Tok_End, "END");
|
|
|
if Token = Tok_End then
|
if Token = Tok_End then
|
|
|
-- Scan past "end"
|
-- Scan past "end"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
-- We should have the name of the package after "end"
|
-- We should have the name of the package after "end"
|
|
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier
|
if Token = Tok_Identifier
|
and then Name_Of (Package_Declaration, In_Tree) /= No_Name
|
and then Name_Of (Package_Declaration, In_Tree) /= No_Name
|
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
|
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
|
then
|
then
|
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
|
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
|
Error_Msg (Flags, "expected %%", Token_Ptr);
|
Error_Msg (Flags, "expected %%", Token_Ptr);
|
end if;
|
end if;
|
|
|
if Token /= Tok_Semicolon then
|
if Token /= Tok_Semicolon then
|
|
|
-- Scan past the package name
|
-- Scan past the package name
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Expect (Tok_Semicolon, "`;`");
|
Expect (Tok_Semicolon, "`;`");
|
Remove_Next_End_Node;
|
Remove_Next_End_Node;
|
|
|
else
|
else
|
Error_Msg (Flags, "expected IS", Token_Ptr);
|
Error_Msg (Flags, "expected IS", Token_Ptr);
|
end if;
|
end if;
|
|
|
end Parse_Package_Declaration;
|
end Parse_Package_Declaration;
|
|
|
-----------------------------------
|
-----------------------------------
|
-- Parse_String_Type_Declaration --
|
-- Parse_String_Type_Declaration --
|
-----------------------------------
|
-----------------------------------
|
|
|
procedure Parse_String_Type_Declaration
|
procedure Parse_String_Type_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
String_Type : out Project_Node_Id;
|
String_Type : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Current : Project_Node_Id := Empty_Node;
|
Current : Project_Node_Id := Empty_Node;
|
First_String : Project_Node_Id := Empty_Node;
|
First_String : Project_Node_Id := Empty_Node;
|
|
|
begin
|
begin
|
String_Type :=
|
String_Type :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
|
(Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
|
|
|
Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
|
Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
|
|
|
-- Scan past "type"
|
-- Scan past "type"
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
Set_Name_Of (String_Type, In_Tree, To => Token_Name);
|
Set_Name_Of (String_Type, In_Tree, To => Token_Name);
|
|
|
Current := First_String_Type_Of (Current_Project, In_Tree);
|
Current := First_String_Type_Of (Current_Project, In_Tree);
|
while Present (Current)
|
while Present (Current)
|
and then
|
and then
|
Name_Of (Current, In_Tree) /= Token_Name
|
Name_Of (Current, In_Tree) /= Token_Name
|
loop
|
loop
|
Current := Next_String_Type (Current, In_Tree);
|
Current := Next_String_Type (Current, In_Tree);
|
end loop;
|
end loop;
|
|
|
if Present (Current) then
|
if Present (Current) then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"duplicate string type name """ &
|
"duplicate string type name """ &
|
Get_Name_String (Token_Name) &
|
Get_Name_String (Token_Name) &
|
"""",
|
"""",
|
Token_Ptr);
|
Token_Ptr);
|
else
|
else
|
Current := First_Variable_Of (Current_Project, In_Tree);
|
Current := First_Variable_Of (Current_Project, In_Tree);
|
while Present (Current)
|
while Present (Current)
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
and then Name_Of (Current, In_Tree) /= Token_Name
|
loop
|
loop
|
Current := Next_Variable (Current, In_Tree);
|
Current := Next_Variable (Current, In_Tree);
|
end loop;
|
end loop;
|
|
|
if Present (Current) then
|
if Present (Current) then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"""" &
|
"""" &
|
Get_Name_String (Token_Name) &
|
Get_Name_String (Token_Name) &
|
""" is already a variable name", Token_Ptr);
|
""" is already a variable name", Token_Ptr);
|
else
|
else
|
Set_Next_String_Type
|
Set_Next_String_Type
|
(String_Type, In_Tree,
|
(String_Type, In_Tree,
|
To => First_String_Type_Of (Current_Project, In_Tree));
|
To => First_String_Type_Of (Current_Project, In_Tree));
|
Set_First_String_Type_Of
|
Set_First_String_Type_Of
|
(Current_Project, In_Tree, To => String_Type);
|
(Current_Project, In_Tree, To => String_Type);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Scan past the name
|
-- Scan past the name
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Expect (Tok_Is, "IS");
|
Expect (Tok_Is, "IS");
|
|
|
if Token = Tok_Is then
|
if Token = Tok_Is then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Expect (Tok_Left_Paren, "`(`");
|
Expect (Tok_Left_Paren, "`(`");
|
|
|
if Token = Tok_Left_Paren then
|
if Token = Tok_Left_Paren then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
Parse_String_Type_List
|
Parse_String_Type_List
|
(In_Tree => In_Tree, First_String => First_String, Flags => Flags);
|
(In_Tree => In_Tree, First_String => First_String, Flags => Flags);
|
Set_First_Literal_String (String_Type, In_Tree, To => First_String);
|
Set_First_Literal_String (String_Type, In_Tree, To => First_String);
|
|
|
Expect (Tok_Right_Paren, "`)`");
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
if Token = Tok_Right_Paren then
|
if Token = Tok_Right_Paren then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
end Parse_String_Type_Declaration;
|
end Parse_String_Type_Declaration;
|
|
|
--------------------------------
|
--------------------------------
|
-- Parse_Variable_Declaration --
|
-- Parse_Variable_Declaration --
|
--------------------------------
|
--------------------------------
|
|
|
procedure Parse_Variable_Declaration
|
procedure Parse_Variable_Declaration
|
(In_Tree : Project_Node_Tree_Ref;
|
(In_Tree : Project_Node_Tree_Ref;
|
Variable : out Project_Node_Id;
|
Variable : out Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Project : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Current_Package : Project_Node_Id;
|
Flags : Processing_Flags)
|
Flags : Processing_Flags)
|
is
|
is
|
Expression_Location : Source_Ptr;
|
Expression_Location : Source_Ptr;
|
String_Type_Name : Name_Id := No_Name;
|
String_Type_Name : Name_Id := No_Name;
|
Project_String_Type_Name : Name_Id := No_Name;
|
Project_String_Type_Name : Name_Id := No_Name;
|
Type_Location : Source_Ptr := No_Location;
|
Type_Location : Source_Ptr := No_Location;
|
Project_Location : Source_Ptr := No_Location;
|
Project_Location : Source_Ptr := No_Location;
|
Expression : Project_Node_Id := Empty_Node;
|
Expression : Project_Node_Id := Empty_Node;
|
Variable_Name : constant Name_Id := Token_Name;
|
Variable_Name : constant Name_Id := Token_Name;
|
OK : Boolean := True;
|
OK : Boolean := True;
|
|
|
begin
|
begin
|
Variable :=
|
Variable :=
|
Default_Project_Node
|
Default_Project_Node
|
(Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
|
(Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
|
Set_Name_Of (Variable, In_Tree, To => Variable_Name);
|
Set_Name_Of (Variable, In_Tree, To => Variable_Name);
|
Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
|
Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
|
|
|
-- Scan past the variable name
|
-- Scan past the variable name
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
if Token = Tok_Colon then
|
if Token = Tok_Colon then
|
|
|
-- Typed string variable declaration
|
-- Typed string variable declaration
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
|
Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
OK := Token = Tok_Identifier;
|
OK := Token = Tok_Identifier;
|
|
|
if OK then
|
if OK then
|
String_Type_Name := Token_Name;
|
String_Type_Name := Token_Name;
|
Type_Location := Token_Ptr;
|
Type_Location := Token_Ptr;
|
Scan (In_Tree);
|
Scan (In_Tree);
|
|
|
if Token = Tok_Dot then
|
if Token = Tok_Dot then
|
Project_String_Type_Name := String_Type_Name;
|
Project_String_Type_Name := String_Type_Name;
|
Project_Location := Type_Location;
|
Project_Location := Type_Location;
|
|
|
-- Scan past the dot
|
-- Scan past the dot
|
|
|
Scan (In_Tree);
|
Scan (In_Tree);
|
Expect (Tok_Identifier, "identifier");
|
Expect (Tok_Identifier, "identifier");
|
|
|
if Token = Tok_Identifier then
|
if Token = Tok_Identifier then
|
String_Type_Name := Token_Name;
|
String_Type_Name := Token_Name;
|
Type_Location := Token_Ptr;
|
Type_Location := Token_Ptr;
|
Scan (In_Tree);
|
Scan (In_Tree);
|
else
|
else
|
OK := False;
|
OK := False;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if OK then
|
if OK then
|
declare
|
declare
|
Proj : Project_Node_Id := Current_Project;
|
Proj : Project_Node_Id := Current_Project;
|
Current : Project_Node_Id := Empty_Node;
|
Current : Project_Node_Id := Empty_Node;
|
|
|
begin
|
begin
|
if Project_String_Type_Name /= No_Name then
|
if Project_String_Type_Name /= No_Name then
|
declare
|
declare
|
The_Project_Name_And_Node : constant
|
The_Project_Name_And_Node : constant
|
Tree_Private_Part.Project_Name_And_Node :=
|
Tree_Private_Part.Project_Name_And_Node :=
|
Tree_Private_Part.Projects_Htable.Get
|
Tree_Private_Part.Projects_Htable.Get
|
(In_Tree.Projects_HT, Project_String_Type_Name);
|
(In_Tree.Projects_HT, Project_String_Type_Name);
|
|
|
use Tree_Private_Part;
|
use Tree_Private_Part;
|
|
|
begin
|
begin
|
if The_Project_Name_And_Node =
|
if The_Project_Name_And_Node =
|
Tree_Private_Part.No_Project_Name_And_Node
|
Tree_Private_Part.No_Project_Name_And_Node
|
then
|
then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"unknown project """ &
|
"unknown project """ &
|
Get_Name_String
|
Get_Name_String
|
(Project_String_Type_Name) &
|
(Project_String_Type_Name) &
|
"""",
|
"""",
|
Project_Location);
|
Project_Location);
|
Current := Empty_Node;
|
Current := Empty_Node;
|
else
|
else
|
Current :=
|
Current :=
|
First_String_Type_Of
|
First_String_Type_Of
|
(The_Project_Name_And_Node.Node, In_Tree);
|
(The_Project_Name_And_Node.Node, In_Tree);
|
while
|
while
|
Present (Current)
|
Present (Current)
|
and then
|
and then
|
Name_Of (Current, In_Tree) /= String_Type_Name
|
Name_Of (Current, In_Tree) /= String_Type_Name
|
loop
|
loop
|
Current := Next_String_Type (Current, In_Tree);
|
Current := Next_String_Type (Current, In_Tree);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end;
|
end;
|
|
|
else
|
else
|
-- Look for a string type with the correct name in this
|
-- Look for a string type with the correct name in this
|
-- project or in any of its ancestors.
|
-- project or in any of its ancestors.
|
|
|
loop
|
loop
|
Current :=
|
Current :=
|
First_String_Type_Of (Proj, In_Tree);
|
First_String_Type_Of (Proj, In_Tree);
|
while
|
while
|
Present (Current)
|
Present (Current)
|
and then
|
and then
|
Name_Of (Current, In_Tree) /= String_Type_Name
|
Name_Of (Current, In_Tree) /= String_Type_Name
|
loop
|
loop
|
Current := Next_String_Type (Current, In_Tree);
|
Current := Next_String_Type (Current, In_Tree);
|
end loop;
|
end loop;
|
|
|
exit when Present (Current);
|
exit when Present (Current);
|
|
|
Proj := Parent_Project_Of (Proj, In_Tree);
|
Proj := Parent_Project_Of (Proj, In_Tree);
|
exit when No (Proj);
|
exit when No (Proj);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
if No (Current) then
|
if No (Current) then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"unknown string type """ &
|
"unknown string type """ &
|
Get_Name_String (String_Type_Name) &
|
Get_Name_String (String_Type_Name) &
|
"""",
|
"""",
|
Type_Location);
|
Type_Location);
|
OK := False;
|
OK := False;
|
|
|
else
|
else
|
Set_String_Type_Of
|
Set_String_Type_Of
|
(Variable, In_Tree, To => Current);
|
(Variable, In_Tree, To => Current);
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Expect (Tok_Colon_Equal, "`:=`");
|
Expect (Tok_Colon_Equal, "`:=`");
|
|
|
OK := OK and then Token = Tok_Colon_Equal;
|
OK := OK and then Token = Tok_Colon_Equal;
|
|
|
if Token = Tok_Colon_Equal then
|
if Token = Tok_Colon_Equal then
|
Scan (In_Tree);
|
Scan (In_Tree);
|
end if;
|
end if;
|
|
|
-- Get the single string or string list value
|
-- Get the single string or string list value
|
|
|
Expression_Location := Token_Ptr;
|
Expression_Location := Token_Ptr;
|
|
|
Parse_Expression
|
Parse_Expression
|
(In_Tree => In_Tree,
|
(In_Tree => In_Tree,
|
Expression => Expression,
|
Expression => Expression,
|
Flags => Flags,
|
Flags => Flags,
|
Current_Project => Current_Project,
|
Current_Project => Current_Project,
|
Current_Package => Current_Package,
|
Current_Package => Current_Package,
|
Optional_Index => False);
|
Optional_Index => False);
|
Set_Expression_Of (Variable, In_Tree, To => Expression);
|
Set_Expression_Of (Variable, In_Tree, To => Expression);
|
|
|
if Present (Expression) then
|
if Present (Expression) then
|
-- A typed string must have a single string value, not a list
|
-- A typed string must have a single string value, not a list
|
|
|
if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
|
if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
|
and then Expression_Kind_Of (Expression, In_Tree) = List
|
and then Expression_Kind_Of (Expression, In_Tree) = List
|
then
|
then
|
Error_Msg
|
Error_Msg
|
(Flags,
|
(Flags,
|
"expression must be a single string", Expression_Location);
|
"expression must be a single string", Expression_Location);
|
end if;
|
end if;
|
|
|
Set_Expression_Kind_Of
|
Set_Expression_Kind_Of
|
(Variable, In_Tree,
|
(Variable, In_Tree,
|
To => Expression_Kind_Of (Expression, In_Tree));
|
To => Expression_Kind_Of (Expression, In_Tree));
|
end if;
|
end if;
|
|
|
if OK then
|
if OK then
|
declare
|
declare
|
The_Variable : Project_Node_Id := Empty_Node;
|
The_Variable : Project_Node_Id := Empty_Node;
|
|
|
begin
|
begin
|
if Present (Current_Package) then
|
if Present (Current_Package) then
|
The_Variable := First_Variable_Of (Current_Package, In_Tree);
|
The_Variable := First_Variable_Of (Current_Package, In_Tree);
|
elsif Present (Current_Project) then
|
elsif Present (Current_Project) then
|
The_Variable := First_Variable_Of (Current_Project, In_Tree);
|
The_Variable := First_Variable_Of (Current_Project, In_Tree);
|
end if;
|
end if;
|
|
|
while Present (The_Variable)
|
while Present (The_Variable)
|
and then Name_Of (The_Variable, In_Tree) /= Variable_Name
|
and then Name_Of (The_Variable, In_Tree) /= Variable_Name
|
loop
|
loop
|
The_Variable := Next_Variable (The_Variable, In_Tree);
|
The_Variable := Next_Variable (The_Variable, In_Tree);
|
end loop;
|
end loop;
|
|
|
if No (The_Variable) then
|
if No (The_Variable) then
|
if Present (Current_Package) then
|
if Present (Current_Package) then
|
Set_Next_Variable
|
Set_Next_Variable
|
(Variable, In_Tree,
|
(Variable, In_Tree,
|
To => First_Variable_Of (Current_Package, In_Tree));
|
To => First_Variable_Of (Current_Package, In_Tree));
|
Set_First_Variable_Of
|
Set_First_Variable_Of
|
(Current_Package, In_Tree, To => Variable);
|
(Current_Package, In_Tree, To => Variable);
|
|
|
elsif Present (Current_Project) then
|
elsif Present (Current_Project) then
|
Set_Next_Variable
|
Set_Next_Variable
|
(Variable, In_Tree,
|
(Variable, In_Tree,
|
To => First_Variable_Of (Current_Project, In_Tree));
|
To => First_Variable_Of (Current_Project, In_Tree));
|
Set_First_Variable_Of
|
Set_First_Variable_Of
|
(Current_Project, In_Tree, To => Variable);
|
(Current_Project, In_Tree, To => Variable);
|
end if;
|
end if;
|
|
|
else
|
else
|
if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
|
if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
|
if Expression_Kind_Of (The_Variable, In_Tree) =
|
if Expression_Kind_Of (The_Variable, In_Tree) =
|
Undefined
|
Undefined
|
then
|
then
|
Set_Expression_Kind_Of
|
Set_Expression_Kind_Of
|
(The_Variable, In_Tree,
|
(The_Variable, In_Tree,
|
To => Expression_Kind_Of (Variable, In_Tree));
|
To => Expression_Kind_Of (Variable, In_Tree));
|
|
|
else
|
else
|
if Expression_Kind_Of (The_Variable, In_Tree) /=
|
if Expression_Kind_Of (The_Variable, In_Tree) /=
|
Expression_Kind_Of (Variable, In_Tree)
|
Expression_Kind_Of (Variable, In_Tree)
|
then
|
then
|
Error_Msg (Flags,
|
Error_Msg (Flags,
|
"wrong expression kind for variable """ &
|
"wrong expression kind for variable """ &
|
Get_Name_String
|
Get_Name_String
|
(Name_Of (The_Variable, In_Tree)) &
|
(Name_Of (The_Variable, In_Tree)) &
|
"""",
|
"""",
|
Expression_Location);
|
Expression_Location);
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
end Parse_Variable_Declaration;
|
end Parse_Variable_Declaration;
|
|
|
end Prj.Dect;
|
end Prj.Dect;
|
|
|
