-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2008, 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Err_Vars; use Err_Vars;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-
+with Err_Vars; use Err_Vars;
with Opt; use Opt;
with Prj.Attr; use Prj.Attr;
with Prj.Attr.PM; use Prj.Attr.PM;
with Snames;
with Uintp; use Uintp;
+with GNAT; use GNAT;
+with GNAT.Case_Util; use GNAT.Case_Util;
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
with GNAT.Strings;
package body Prj.Dect is
- use GNAT;
-
type Zone is (In_Project, In_Package, In_Case_Construction);
- -- Used to indicate if we are parsing a package (In_Package),
- -- a case construction (In_Case_Construction) or none of those two
- -- (In_Project).
+ -- Used to indicate if we are parsing a package (In_Package), a case
+ -- construction (In_Case_Construction) or none of those two (In_Project).
+
+ procedure Rename_Obsolescent_Attributes
+ (In_Tree : Project_Node_Tree_Ref;
+ Attribute : Project_Node_Id;
+ Current_Package : Project_Node_Id);
+ -- Rename obsolescent attributes in the tree. When the attribute has been
+ -- renamed since its initial introduction in the design of projects, we
+ -- replace the old name in the tree with the new name, so that the code
+ -- does not have to check both names forever.
+
+ procedure Check_Attribute_Allowed
+ (In_Tree : Project_Node_Tree_Ref;
+ Project : Project_Node_Id;
+ Attribute : Project_Node_Id;
+ Flags : Processing_Flags);
+ -- Check whether the attribute is valid in this project. In particular,
+ -- depending on the type of project (qualifier), some attributes might
+ -- be disabled.
+
+ procedure Check_Package_Allowed
+ (In_Tree : Project_Node_Tree_Ref;
+ Project : Project_Node_Id;
+ Current_Package : Project_Node_Id;
+ Flags : Processing_Flags);
+ -- Check whether the package is valid in this project
procedure Parse_Attribute_Declaration
(In_Tree : Project_Node_Tree_Ref;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access);
+ Packages_To_Check : String_List_Access;
+ Flags : Processing_Flags);
-- Parse an attribute declaration
procedure Parse_Case_Construction
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access);
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags);
-- Parse a case construction
procedure Parse_Declarative_Items
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access);
- -- Parse declarative items. Depending on In_Zone, some declarative
- -- items may be forbidden.
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags);
+ -- Parse declarative items. Depending on In_Zone, some declarative items
+ -- may be forbidden. Is_Config_File should be set to True if the project
+ -- represents a config file (.cgpr) since some specific checks apply.
procedure Parse_Package_Declaration
(In_Tree : Project_Node_Tree_Ref;
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
- Packages_To_Check : String_List_Access);
- -- Parse a package declaration
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags);
+ -- Parse a package declaration.
+ -- Is_Config_File should be set to True if the project represents a config
+ -- file (.cgpr) since some specific checks apply.
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
- Current_Project : Project_Node_Id);
+ Current_Project : Project_Node_Id;
+ Flags : Processing_Flags);
-- type <name> is ( <literal_string> { , <literal_string> } ) ;
procedure Parse_Variable_Declaration
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id);
+ Current_Package : Project_Node_Id;
+ Flags : Processing_Flags);
-- Parse a variable assignment
-- <variable_Name> := <expression>; OR
-- <variable_Name> : <string_type_Name> := <string_expression>;
Declarations : out Project_Node_Id;
Current_Project : Project_Node_Id;
Extends : Project_Node_Id;
- Packages_To_Check : String_List_Access)
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags)
is
First_Declarative_Item : Project_Node_Id := Empty_Node;
First_Attribute => Prj.Attr.Attribute_First,
Current_Project => Current_Project,
Current_Package => Empty_Node,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
Set_First_Declarative_Item_Of
(Declarations, In_Tree, To => First_Declarative_Item);
end Parse;
+ -----------------------------------
+ -- Rename_Obsolescent_Attributes --
+ -----------------------------------
+
+ procedure Rename_Obsolescent_Attributes
+ (In_Tree : Project_Node_Tree_Ref;
+ Attribute : Project_Node_Id;
+ Current_Package : Project_Node_Id)
+ is
+ begin
+ if Present (Current_Package)
+ and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
+ then
+ case Name_Of (Attribute, In_Tree) is
+ when Snames.Name_Specification =>
+ Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
+
+ when Snames.Name_Specification_Suffix =>
+ Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
+
+ when Snames.Name_Implementation =>
+ Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
+
+ when Snames.Name_Implementation_Suffix =>
+ Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
+
+ when others =>
+ null;
+ end case;
+ end if;
+ end Rename_Obsolescent_Attributes;
+
+ ---------------------------
+ -- Check_Package_Allowed --
+ ---------------------------
+
+ procedure Check_Package_Allowed
+ (In_Tree : Project_Node_Tree_Ref;
+ Project : Project_Node_Id;
+ Current_Package : Project_Node_Id;
+ Flags : Processing_Flags)
+ is
+ Qualif : constant Project_Qualifier :=
+ Project_Qualifier_Of (Project, In_Tree);
+ Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
+ begin
+ if Qualif in Aggregate_Project
+ and then Name /= Snames.Name_Builder
+ then
+ Error_Msg_Name_1 := Name;
+ Error_Msg
+ (Flags,
+ "package %% is forbidden in aggregate projects",
+ Location_Of (Current_Package, In_Tree));
+ end if;
+ end Check_Package_Allowed;
+
+ -----------------------------
+ -- Check_Attribute_Allowed --
+ -----------------------------
+
+ procedure Check_Attribute_Allowed
+ (In_Tree : Project_Node_Tree_Ref;
+ Project : Project_Node_Id;
+ Attribute : Project_Node_Id;
+ Flags : Processing_Flags)
+ is
+ Qualif : constant Project_Qualifier :=
+ Project_Qualifier_Of (Project, In_Tree);
+ Name : constant Name_Id := Name_Of (Attribute, In_Tree);
+
+ begin
+ case Qualif is
+ when Aggregate | Aggregate_Library =>
+ if Name = Snames.Name_Languages
+ or else Name = Snames.Name_Source_Files
+ or else Name = Snames.Name_Source_List_File
+ or else Name = Snames.Name_Locally_Removed_Files
+ or else Name = Snames.Name_Excluded_Source_Files
+ or else Name = Snames.Name_Excluded_Source_List_File
+ or else Name = Snames.Name_Interfaces
+ or else Name = Snames.Name_Object_Dir
+ or else Name = Snames.Name_Exec_Dir
+ or else Name = Snames.Name_Source_Dirs
+ or else Name = Snames.Name_Inherit_Source_Path
+ then
+ Error_Msg_Name_1 := Name;
+ Error_Msg
+ (Flags,
+ "%% is not valid in aggregate projects",
+ Location_Of (Attribute, In_Tree));
+ end if;
+
+ when others =>
+ if Name = Snames.Name_Project_Files
+ or else Name = Snames.Name_Project_Path
+ or else Name = Snames.Name_External
+ then
+ Error_Msg_Name_1 := Name;
+ Error_Msg
+ (Flags,
+ "%% is only valid in aggregate projects",
+ Location_Of (Attribute, In_Tree));
+ end if;
+ end case;
+ end Check_Attribute_Allowed;
+
---------------------------------
-- Parse_Attribute_Declaration --
---------------------------------
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access)
+ Packages_To_Check : String_List_Access;
+ Flags : Processing_Flags)
is
Current_Attribute : Attribute_Node_Id := First_Attribute;
Full_Associative_Array : Boolean := False;
Attribute_Name : Name_Id := No_Name;
Optional_Index : Boolean := False;
Pkg_Id : Package_Node_Id := Empty_Package;
- Ignore : Boolean := False;
- begin
- Attribute :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
- Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
- Set_Previous_Line_Node (Attribute);
+ procedure Process_Attribute_Name;
+ -- Read the name of the attribute, and check its type
- -- Scan past "for"
+ procedure Process_Associative_Array_Index;
+ -- Read the index of the associative array and check its validity
- Scan (In_Tree);
+ ----------------------------
+ -- Process_Attribute_Name --
+ ----------------------------
- -- Body may be an attribute name
+ procedure Process_Attribute_Name is
+ Ignore : Boolean;
- if Token = Tok_Body then
- Token := Tok_Identifier;
- Token_Name := Snames.Name_Body;
- end if;
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
+ begin
Attribute_Name := Token_Name;
- Set_Name_Of (Attribute, In_Tree, To => Token_Name);
+ Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
-- Find the attribute
Current_Attribute :=
- Attribute_Node_Id_Of (Token_Name, First_Attribute);
+ Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
-- If the attribute cannot be found, create the attribute if inside
-- an unknown package.
if not Ignore then
Error_Msg_Name_1 := Token_Name;
- Error_Msg ("undefined attribute %%", Token_Ptr);
+ Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
end if;
end if;
if Is_Read_Only (Current_Attribute) then
Error_Msg_Name_1 := Token_Name;
Error_Msg
- ("read-only attribute %% cannot be given a value",
+ (Flags, "read-only attribute %% cannot be given a value",
Token_Ptr);
end if;
if Attribute_Kind_Of (Current_Attribute) in
- Case_Insensitive_Associative_Array ..
- Optional_Index_Case_Insensitive_Associative_Array
+ All_Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, In_Tree, To => True);
end if;
end if;
Scan (In_Tree); -- past the attribute name
- end if;
-
- -- Change obsolete names of attributes to the new names
-
- if Present (Current_Package)
- and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
- then
- case Name_Of (Attribute, In_Tree) is
- when Snames.Name_Specification =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
- when Snames.Name_Specification_Suffix =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
-
- when Snames.Name_Implementation =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
-
- when Snames.Name_Implementation_Suffix =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
-
- when others =>
- null;
- end case;
- end if;
+ -- Set the expression kind of the attribute
- -- Associative array attributes
+ if Current_Attribute /= Empty_Attribute then
+ Set_Expression_Kind_Of
+ (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
+ Optional_Index := Optional_Index_Of (Current_Attribute);
+ end if;
+ end Process_Attribute_Name;
- if Token = Tok_Left_Paren then
+ -------------------------------------
+ -- Process_Associative_Array_Index --
+ -------------------------------------
+ procedure Process_Associative_Array_Index is
+ begin
-- If the attribute is not an associative array attribute, report
-- an error. If this information is still unknown, set the kind
-- to Associative_Array.
if Current_Attribute /= Empty_Attribute
and then Attribute_Kind_Of (Current_Attribute) = Single
then
- Error_Msg ("the attribute """ &
- Get_Name_String
- (Attribute_Name_Of (Current_Attribute)) &
- """ cannot be an associative array",
+ Error_Msg (Flags,
+ "the attribute """ &
+ Get_Name_String (Attribute_Name_Of (Current_Attribute))
+ & """ cannot be an associative array",
Location_Of (Attribute, In_Tree));
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
- Error_Msg ("index cannot be zero", Token_Ptr);
+ Error_Msg
+ (Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Attribute, In_Tree, To => Index);
end if;
when others =>
- Error_Msg ("index not allowed here", Token_Ptr);
+ Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
if Token = Tok_Integer_Literal then
if Token = Tok_Right_Paren then
Scan (In_Tree); -- past the right parenthesis
end if;
+ end Process_Associative_Array_Index;
+
+ begin
+ Attribute :=
+ Default_Project_Node
+ (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
+ Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
+ Set_Previous_Line_Node (Attribute);
+
+ -- Scan past "for"
+
+ Scan (In_Tree);
+
+ -- Body or External may be an attribute name
+
+ if Token = Tok_Body then
+ Token := Tok_Identifier;
+ Token_Name := Snames.Name_Body;
+ end if;
+
+ if Token = Tok_External then
+ Token := Tok_Identifier;
+ Token_Name := Snames.Name_External;
+ end if;
+
+ Expect (Tok_Identifier, "identifier");
+ Process_Attribute_Name;
+ Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
+ Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
+
+ -- Associative array attributes
+
+ if Token = Tok_Left_Paren then
+ Process_Associative_Array_Index;
else
-- If it is an associative array attribute and there are no left
end if;
end if;
- -- Set the expression kind of the attribute
-
- if Current_Attribute /= Empty_Attribute then
- Set_Expression_Kind_Of
- (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
- Optional_Index := Optional_Index_Of (Current_Attribute);
- end if;
-
Expect (Tok_Use, "USE");
if Token = Tok_Use then
(Current_Project, In_Tree, Token_Name);
if No (The_Project) then
- Error_Msg ("unknown project", Location);
+ Error_Msg (Flags, "unknown project", Location);
Scan (In_Tree); -- past the project name
else
then
The_Project := Empty_Node;
Error_Msg
- ("not the same package as " &
+ (Flags, "not the same package as " &
Get_Name_String
(Name_Of (Current_Package, In_Tree)),
Token_Ptr);
Error_Msg_Name_2 := Project_Name;
Error_Msg_Name_1 := Token_Name;
Error_Msg
- ("package % not declared in project %",
- Token_Ptr);
+ (Flags,
+ "package % not declared in project %",
+ Token_Ptr);
end if;
Scan (In_Tree); -- past the package name
if Token_Name /= Attribute_Name then
The_Project := Empty_Node;
Error_Msg_Name_1 := Attribute_Name;
- Error_Msg ("invalid name, should be %", Token_Ptr);
+ Error_Msg
+ (Flags, "invalid name, should be %", Token_Ptr);
end if;
Scan (In_Tree); -- past the attribute name
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
+ Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);
else
Error_Msg
- ("wrong expression kind for attribute """ &
+ (Flags, "wrong expression kind for attribute """ &
Get_Name_String
(Attribute_Name_Of (Current_Attribute)) &
"""",
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access)
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags)
is
Current_Item : Project_Node_Id := Empty_Node;
Next_Item : Project_Node_Id := Empty_Node;
Parse_Variable_Reference
(In_Tree => In_Tree,
Variable => Case_Variable,
+ Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Case_Variable_Reference_Of
String_Type := String_Type_Of (Case_Variable, In_Tree);
if No (String_Type) then
- Error_Msg ("variable """ &
+ Error_Msg (Flags,
+ "variable """ &
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
""" is not typed",
Variable_Location);
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
-- "when others =>" must be the last branch, so save the
-- Case_Item and exit
else
Parse_Choice_List
(In_Tree => In_Tree,
- First_Choice => First_Choice);
+ First_Choice => First_Choice,
+ Flags => Flags);
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
Set_First_Declarative_Item_Of
(Current_Item, In_Tree, To => First_Declarative_Item);
End_Case_Construction
(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);
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access)
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags)
is
Current_Declarative_Item : Project_Node_Id := Empty_Node;
Next_Declarative_Item : Project_Node_Id := Empty_Node;
if No (The_Variable) then
Error_Msg
- ("a variable cannot be declared " &
+ (Flags,
+ "a variable cannot be declared " &
"for the first time here",
Token_Ptr);
end if;
(In_Tree,
Current_Declaration,
Current_Project => Current_Project,
- Current_Package => Current_Package);
+ Current_Package => Current_Package,
+ Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
-- Package declaration
if In_Zone /= In_Project then
- Error_Msg ("a package cannot be declared here", Token_Ptr);
+ Error_Msg
+ (Flags, "a package cannot be declared here", Token_Ptr);
end if;
Parse_Package_Declaration
(In_Tree => In_Tree,
Package_Declaration => Current_Declaration,
Current_Project => Current_Project,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
-- Type String Declaration
if In_Zone /= In_Project then
- Error_Msg ("a string type cannot be declared here",
+ Error_Msg (Flags,
+ "a string type cannot be declared here",
Token_Ptr);
end if;
Parse_String_Type_Declaration
(In_Tree => In_Tree,
String_Type => Current_Declaration,
- Current_Project => Current_Project);
+ Current_Project => Current_Project,
+ Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
(In_Tree : Project_Node_Tree_Ref;
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
- Packages_To_Check : String_List_Access)
+ Packages_To_Check : String_List_Access;
+ Is_Config_File : Boolean;
+ Flags : Processing_Flags)
is
First_Attribute : Attribute_Node_Id := Empty_Attribute;
Current_Package : Package_Node_Id := Empty_Package;
First_Declarative_Item : Project_Node_Id := Empty_Node;
-
Package_Location : constant Source_Ptr := Token_Ptr;
+ Renaming : Boolean := False;
+ Extending : Boolean := False;
begin
Package_Declaration :=
-- misspelling has been found.
if Verbose_Mode or else Index /= 0 then
- Error_Msg ("?""" &
+ Error_Msg (Flags,
+ "?""" &
Get_Name_String
(Name_Of (Package_Declaration, In_Tree)) &
""" is not a known package name",
end if;
if Index /= 0 then
- Error_Msg ("\?possible misspelling of """ &
- List (Index).all & """",
- Token_Ptr);
+ Error_Msg -- CODEFIX
+ (Flags,
+ "\?possible misspelling of """ &
+ List (Index).all & """", Token_Ptr);
end if;
end;
end if;
if Present (Current) then
Error_Msg
- ("package """ &
+ (Flags,
+ "package """ &
Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
""" is declared twice in the same project",
Token_Ptr);
Scan (In_Tree);
end if;
+ Check_Package_Allowed
+ (In_Tree, Current_Project, Package_Declaration, Flags);
+
if Token = Tok_Renames then
- if In_Configuration then
+ Renaming := True;
+ elsif Token = Tok_Extends then
+ Extending := True;
+ end if;
+
+ if Renaming or else Extending then
+ if Is_Config_File then
Error_Msg
- ("no package renames in configuration projects", Token_Ptr);
+ (Flags,
+ "no package rename or extension in configuration projects",
+ Token_Ptr);
end if;
- -- Scan past "renames"
+ -- Scan past "renames" or "extends"
Scan (In_Tree);
else
Error_Msg_Name_1 := Project_Name;
Error_Msg
- ("% is not an imported or extended project", Token_Ptr);
+ (Flags,
+ "% is not an imported or extended project", Token_Ptr);
end if;
else
Set_Project_Of_Renamed_Package_Of
if Token = Tok_Identifier then
if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
- Error_Msg ("not the same package name", Token_Ptr);
+ Error_Msg (Flags, "not the same package name", Token_Ptr);
elsif
Present (Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree))
if No (Current) then
Error_Msg
- ("""" &
+ (Flags, """" &
Get_Name_String (Token_Name) &
""" is not a package declared by the project",
Token_Ptr);
end if;
end if;
end if;
+ end if;
+ if Renaming then
Expect (Tok_Semicolon, "`;`");
Set_End_Of_Line (Package_Declaration);
Set_Previous_Line_Node (Package_Declaration);
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Package_Declaration,
- Packages_To_Check => Packages_To_Check);
+ Packages_To_Check => Packages_To_Check,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
Set_First_Declarative_Item_Of
(Package_Declaration, In_Tree, To => First_Declarative_Item);
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
then
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
- Error_Msg ("expected %%", Token_Ptr);
+ Error_Msg (Flags, "expected %%", Token_Ptr);
end if;
if Token /= Tok_Semicolon then
Remove_Next_End_Node;
else
- Error_Msg ("expected IS or RENAMES", Token_Ptr);
+ Error_Msg (Flags, "expected IS", Token_Ptr);
end if;
end Parse_Package_Declaration;
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
- Current_Project : Project_Node_Id)
+ Current_Project : Project_Node_Id;
+ Flags : Processing_Flags)
is
Current : Project_Node_Id := Empty_Node;
First_String : Project_Node_Id := Empty_Node;
end loop;
if Present (Current) then
- Error_Msg ("duplicate string type name """ &
+ Error_Msg (Flags,
+ "duplicate string type name """ &
Get_Name_String (Token_Name) &
"""",
Token_Ptr);
end loop;
if Present (Current) then
- Error_Msg ("""" &
+ Error_Msg (Flags,
+ """" &
Get_Name_String (Token_Name) &
""" is already a variable name", Token_Ptr);
else
end if;
Parse_String_Type_List
- (In_Tree => In_Tree, First_String => First_String);
+ (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
Set_First_Literal_String (String_Type, In_Tree, To => First_String);
Expect (Tok_Right_Paren, "`)`");
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id)
+ Current_Package : Project_Node_Id;
+ Flags : Processing_Flags)
is
Expression_Location : Source_Ptr;
String_Type_Name : Name_Id := No_Name;
if The_Project_Name_And_Node =
Tree_Private_Part.No_Project_Name_And_Node
then
- Error_Msg ("unknown project """ &
+ Error_Msg (Flags,
+ "unknown project """ &
Get_Name_String
(Project_String_Type_Name) &
"""",
end if;
if No (Current) then
- Error_Msg ("unknown string type """ &
+ Error_Msg (Flags,
+ "unknown string type """ &
Get_Name_String (String_Type_Name) &
"""",
Type_Location);
Expect (Tok_Colon_Equal, "`:=`");
- OK := OK and (Token = Tok_Colon_Equal);
+ OK := OK and then Token = Tok_Colon_Equal;
if Token = Tok_Colon_Equal then
Scan (In_Tree);
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
+ Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => False);
and then Expression_Kind_Of (Expression, In_Tree) = List
then
Error_Msg
- ("expression must be a single string", Expression_Location);
+ (Flags,
+ "expression must be a single string", Expression_Location);
end if;
Set_Expression_Kind_Of
if Expression_Kind_Of (The_Variable, In_Tree) /=
Expression_Kind_Of (Variable, In_Tree)
then
- Error_Msg ("wrong expression kind for variable """ &
+ Error_Msg (Flags,
+ "wrong expression kind for variable """ &
Get_Name_String
(Name_Of (The_Variable, In_Tree)) &
"""",
OSDN Git Service
