[Ada] Parser clean ups and improvements.
Arnaud Charlet
charlet@adacore.com
Tue Oct 31 19:52:00 GMT 2006
Tested on i686-linux, committed on trunk.
Parentheses are not permitted around a range or subtype mark in a
membership test and other contexts, but the compiler did not check
for this. This patch introduces an appropriate error check:
1. procedure b is
2. type r is range 1 .. 10;
3. mr : r;
4. begin
5. if mr in (r) then
|
>>> parentheses not allowed for range or subtype mark
6. null;
7. end if;
8. end;
There was also a bug in the parser forbiding the use of "abstract limited"
for derivations. After this patch this problem is fixed and
gnat.dg/specs/abstract_limited.ads compiles without errors.
Finally, the frontend was incorrectly accepting the reserved word "abstract" in
interface type definitions:
--
package P is
type T1 is abstract interface; -- ERROR
type T2 is abstract limited interface; -- ERROR
type T3 is abstract protected interface; -- ERROR
type T4 is abstract task interface; -- ERROR
type T5 is abstract synchronized interface; -- ERROR
end P;
--
After this patch, the compilation of the previous test generates
the following errors:
--
Command: gcc -c -gnat05 -gnatf p.ads
Output:
p.ads:2:15: "abstract" not allowed in interface type definition (RM 3.9.4(2/2))
p.ads:3:23: "tagged" expected
p.ads:3:24: "abstract" not allowed in interface type definition (RM 3.9.4(2/2))
p.ads:4:24: "abstract" not allowed in interface type definition (RM 3.9.4(2/2))
p.ads:5:24: "abstract" not allowed in interface type definition (RM 3.9.4(2/2))
p.ads:6:24: "abstract" not allowed in interface type definition (RM 3.9.4(2/2))
2006-10-31 Robert Dewar <dewar@adacore.com>
Javier Miranda <miranda@adacore.com>
* par-ch3.adb (P_Range_Or_Subtype_Mark): Check for bad parentheses
(P_Type_Declaration): Remove barrier against the reserved word "limited"
after "abstract" to give support to the new syntax of AARM 3.4 (2/2).
(P_Type_Declaration): Minor code cleanup. Add support for synchronized
private extensions.
(P_Type_Declaration): Add the new actual Abstract_Present to every call
to P_Interface_Type_Definition.
(P_Interface_Type_Definition): Addition of one formal to report an error
if the reserved word abstract has been previously found.
(P_Identifier_Declarations): Update grammar rules. Handle parsing of an
object renaming declaration with an access definition or subtype mark
with a possible null exclusion.
* par-ch9.adb: Minor error msg fix
* par-load.adb: Add missing continuation mark to error msg
* par-tchk.adb: (Wrong_Token): Code cleanup, use concatenation
-------------- next part --------------
Index: par-ch3.adb
===================================================================
--- par-ch3.adb (revision 118179)
+++ par-ch3.adb (working copy)
@@ -228,7 +228,7 @@ package body Ch3 is
-- | CONCURRENT_TYPE_DECLARATION
-- INCOMPLETE_TYPE_DECLARATION ::=
- -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED];
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
@@ -236,8 +236,9 @@ package body Ch3 is
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION
- -- [and INTERFACE_LIST] with private;
+ -- [abstract] [limited | synchronized]
+ -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
+ -- with private;
-- TYPE_DEFINITION ::=
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
@@ -251,7 +252,7 @@ package body Ch3 is
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized ] interface
- -- [AND interface_list]
+ -- [and INTERFACE_LIST]
-- Error recovery: can raise Error_Resync
@@ -262,16 +263,16 @@ package body Ch3 is
-- function handles only declarations starting with TYPE).
function P_Type_Declaration return Node_Id is
- Abstract_Present : Boolean;
- Abstract_Loc : Source_Ptr;
+ Abstract_Present : Boolean := False;
+ Abstract_Loc : Source_Ptr := No_Location;
Decl_Node : Node_Id;
Discr_List : List_Id;
Discr_Sloc : Source_Ptr;
End_Labl : Node_Id;
- Type_Loc : Source_Ptr;
- Type_Start_Col : Column_Number;
Ident_Node : Node_Id;
Is_Derived_Iface : Boolean := False;
+ Type_Loc : Source_Ptr;
+ Type_Start_Col : Column_Number;
Unknown_Dis : Boolean;
Typedef_Node : Node_Id;
@@ -384,17 +385,15 @@ package body Ch3 is
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
- if Token = Tok_Limited
+ -- Ada 2005 (AI-419): AARM 3.4 (2/2)
+
+ if (Ada_Version < Ada_05 and then Token = Tok_Limited)
or else Token = Tok_Private
or else Token = Tok_Record
or else Token = Tok_Null
then
Error_Msg_AP ("TAGGED expected");
end if;
-
- else
- Abstract_Present := False;
- Abstract_Loc := No_Location;
end if;
-- Check for misuse of Ada 95 keyword Tagged
@@ -636,7 +635,8 @@ package body Ch3 is
and then Chars (Token_Node) = Name_Interface)
then
Typedef_Node := P_Interface_Type_Definition
- (Is_Synchronized => False);
+ (Abstract_Present,
+ Is_Synchronized => False);
Abstract_Present := True;
Set_Limited_Present (Typedef_Node);
@@ -722,7 +722,7 @@ package body Ch3 is
when Tok_Interface =>
Typedef_Node := P_Interface_Type_Definition
- (Is_Synchronized => False);
+ (Abstract_Present, Is_Synchronized => False);
Abstract_Present := True;
TF_Semicolon;
exit;
@@ -733,7 +733,8 @@ package body Ch3 is
TF_Semicolon;
exit;
- -- Ada 2005 (AI-345)
+ -- Ada 2005 (AI-345): Protected, synchronized or task interface
+ -- or Ada 2005 (AI-443): Synchronized private extension.
when Tok_Protected |
Tok_Synchronized |
@@ -745,24 +746,40 @@ package body Ch3 is
begin
Scan; -- past TASK, PROTECTED or SYNCHRONIZED
- Typedef_Node := P_Interface_Type_Definition
- (Is_Synchronized => True);
- Abstract_Present := True;
-
- case Saved_Token is
- when Tok_Task =>
- Set_Task_Present (Typedef_Node);
+ -- Synchronized private extension
- when Tok_Protected =>
- Set_Protected_Present (Typedef_Node);
+ if Token = Tok_New then
+ Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
- when Tok_Synchronized =>
+ if Saved_Token = Tok_Synchronized then
Set_Synchronized_Present (Typedef_Node);
+ else
+ Error_Msg_SC ("invalid kind of private extension");
+ end if;
+
+ -- Interface
- when others =>
- pragma Assert (False);
- null;
- end case;
+ else
+ Typedef_Node :=
+ P_Interface_Type_Definition
+ (Abstract_Present, Is_Synchronized => True);
+ Abstract_Present := True;
+
+ case Saved_Token is
+ when Tok_Task =>
+ Set_Task_Present (Typedef_Node);
+
+ when Tok_Protected =>
+ Set_Protected_Present (Typedef_Node);
+
+ when Tok_Synchronized =>
+ Set_Synchronized_Present (Typedef_Node);
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+ end if;
end;
TF_Semicolon;
@@ -904,7 +921,7 @@ package body Ch3 is
-------------------------------
-- SUBTYPE_INDICATION ::=
- -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
+ -- [not null] SUBTYPE_MARK [CONSTRAINT]
-- Error recovery: can raise Error_Resync
@@ -1178,8 +1195,10 @@ package body Ch3 is
-- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
-- OBJECT_RENAMING_DECLARATION ::=
- -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
- -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
+ -- DEFINING_IDENTIFIER :
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER :
+ -- ACCESS_DEFINITION renames object_NAME;
-- EXCEPTION_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : exception renames exception_NAME;
@@ -1560,13 +1579,15 @@ package body Ch3 is
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- ACCESS_DEFINITION [:= EXPRESSION];
-- OBJECT_RENAMING_DECLARATION ::=
- -- ...
- -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
+ -- DEFINING_IDENTIFIER :
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER :
+ -- ACCESS_DEFINITION renames object_NAME;
- Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
if Token = Tok_Access then
if Ada_Version < Ada_05 then
@@ -1598,9 +1619,22 @@ package body Ch3 is
-- Object renaming declaration
if Token_Is_Renames then
- Error_Msg_SP
- ("null-exclusion not allowed in object renamings");
- raise Error_Resync;
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("null-exclusion not allowed in object renaming");
+ raise Error_Resync;
+
+ -- Ada 2005 (AI-423): Object renaming declaration with
+ -- a null exclusion.
+
+ else
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+ Set_Subtype_Mark (Decl_Node, Type_Node);
+ Set_Name (Decl_Node, P_Name);
+ end if;
-- Object declaration
@@ -1762,12 +1796,13 @@ package body Ch3 is
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
- -- [[AND interface_list] RECORD_EXTENSION_PART]
+ -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] [limited] new ancestor_SUBTYPE_INDICATION
- -- [AND interface_list] with PRIVATE;
+ -- [abstract] [limited | synchronized]
+ -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
+ -- with private;
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
@@ -1953,7 +1988,8 @@ package body Ch3 is
-- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
-- This routine scans out the range or subtype mark that forms the right
- -- operand of a membership test.
+ -- operand of a membership test (it is not used in any other contexts, and
+ -- error messages are specialized with this knowledge in mind).
-- Note: as documented in the Sinfo interface, although the syntax only
-- allows a subtype mark, we in fact allow any simple expression to be
@@ -1968,10 +2004,23 @@ package body Ch3 is
function P_Range_Or_Subtype_Mark return Node_Id is
Expr_Node : Node_Id;
Range_Node : Node_Id;
+ Save_Loc : Source_Ptr;
+
+ -- Start of processing for P_Range_Or_Subtype_Mark
begin
+ -- Save location of possible junk parentheses
+
+ Save_Loc := Token_Ptr;
+
+ -- Scan out either a simple expression or a range (this accepts more
+ -- than is legal here, but as explained above, we like to allow more
+ -- with a proper diagnostic.
+
Expr_Node := P_Simple_Expression_Or_Range_Attribute;
+ -- Range attribute
+
if Expr_Form = EF_Range_Attr then
return Expr_Node;
@@ -1994,8 +2043,7 @@ package body Ch3 is
-- Check for error of range constraint after a subtype mark
if Token = Tok_Range then
- Error_Msg_SC
- ("range constraint not allowed in membership test");
+ Error_Msg_SC ("range constraint not allowed in membership test");
Scan; -- past RANGE
raise Error_Resync;
@@ -2003,22 +2051,33 @@ package body Ch3 is
elsif Token = Tok_Digits or else Token = Tok_Delta then
Error_Msg_SC
- ("accuracy definition not allowed in membership test");
+ ("accuracy definition not allowed in membership test");
Scan; -- past DIGITS or DELTA
raise Error_Resync;
+ -- Attribute reference, may or may not be OK, but in any case we
+ -- will scan it out
+
elsif Token = Tok_Apostrophe then
return P_Subtype_Mark_Attribute (Expr_Node);
+ -- OK case of simple name, just return it
+
else
return Expr_Node;
end if;
- -- At this stage, we have some junk following the expression. We
- -- really can't tell what is wrong, might be a missing semicolon,
- -- or a missing THEN, or whatever. Our caller will figure it out!
+ -- Here we have some kind of error situation. Check for junk parens
+ -- then return what we have, caller will deal with other errors.
else
+ if Nkind (Expr_Node) in N_Subexpr
+ and then Paren_Count (Expr_Node) /= 0
+ then
+ Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
+ Set_Paren_Count (Expr_Node, 0);
+ end if;
+
return Expr_Node;
end if;
end P_Range_Or_Subtype_Mark;
@@ -3502,12 +3561,13 @@ package body Ch3 is
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized] interface
- -- [AND interface_list]
+ -- [and INTERFACE_LIST]
-- Error recovery: cannot raise Error_Resync
function P_Interface_Type_Definition
- (Is_Synchronized : Boolean) return Node_Id
+ (Abstract_Present : Boolean;
+ Is_Synchronized : Boolean) return Node_Id
is
Typedef_Node : Node_Id;
@@ -3517,6 +3577,11 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
+ if Abstract_Present then
+ Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
+ "('R'M' 3.9.4(2/2))");
+ end if;
+
Scan; -- past INTERFACE
-- Ada 2005 (AI-345): In case of synchronized interfaces and
Index: par-ch9.adb
===================================================================
--- par-ch9.adb (revision 118179)
+++ par-ch9.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
@@ -1545,7 +1545,7 @@ package body Ch9 is
else
Error_Msg_SC
- ("Select alternative (ACCEPT, ABORT, DELAY) expected");
+ ("select alternative (ACCEPT, ABORT, DELAY) expected");
Alternative := Error;
if Token = Tok_Semicolon then
Index: par-load.adb
===================================================================
--- par-load.adb (revision 118179)
+++ par-load.adb (working copy)
@@ -237,9 +237,9 @@ begin
else
Error_Msg ("file { does not contain expected unit!", Loc);
Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
- Error_Msg ("expected unit $!", Loc);
+ Error_Msg ("\\expected unit $!", Loc);
Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
- Error_Msg ("found unit $!", Loc);
+ Error_Msg ("\\found unit $!", Loc);
end if;
-- In both cases, remove the unit if it is the last unit (which it
Index: par-tchk.adb
===================================================================
--- par-tchk.adb (revision 118179)
+++ par-tchk.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
@@ -795,17 +795,12 @@ package body Tchk is
-----------------
procedure Wrong_Token (T : Token_Type; P : Position) is
- Missing : constant String := "missing ";
- Image : constant String := Token_Type'Image (T);
+ Missing : constant String := "missing ";
+ Image : constant String := Token_Type'Image (T);
Tok_Name : constant String := Image (5 .. Image'Length);
- M : String (1 .. Missing'Length + Tok_Name'Length);
+ M : constant String := Missing & Tok_Name;
begin
- -- Set M to Missing & Tok_Name
-
- M (1 .. Missing'Length) := Missing;
- M (Missing'Length + 1 .. M'Last) := Tok_Name;
-
if Token = Tok_Semicolon then
Scan;
More information about the Gcc-patches
mailing list