par-ch3.adb (P_Range_Or_Subtype_Mark): Check for bad parentheses

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

From-SVN: r118290

gcc/ada/par-ch3.adb

@@ -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,8 +746,23 @@ package body Ch3 is
                begin
                   Scan; -- past TASK, PROTECTED or SYNCHRONIZED
 
-                  Typedef_Node := P_Interface_Type_Definition
-                                   (Is_Synchronized => True);
+                  --  Synchronized private extension
+
+                  if Token = Tok_New then
+                     Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+
+                     if Saved_Token = Tok_Synchronized then
+                        Set_Synchronized_Present (Typedef_Node);
+                     else
+                        Error_Msg_SC ("invalid kind of private extension");
+                     end if;
+
+                  --  Interface
+
+                  else
+                     Typedef_Node :=
+                       P_Interface_Type_Definition
+                         (Abstract_Present, Is_Synchronized => True);
                      Abstract_Present := True;
 
                      case Saved_Token is
@@ -763,6 +779,7 @@ package body Ch3 is
                            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;
@@ -1563,10 +1582,12 @@ package body Ch3 is
             --      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,10 +1619,23 @@ package body Ch3 is
                --  Object renaming declaration
 
                if Token_Is_Renames then
+                  if Ada_Version < Ada_05 then
                      Error_Msg_SP
-                    ("null-exclusion not allowed in object renamings");
+                       ("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
 
                else
@@ -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;
 
@@ -2007,18 +2055,29 @@ package body Ch3 is
             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

gcc/ada/par-ch9.adb

@@ -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

gcc/ada/par-load.adb

@@ -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

gcc/ada/par-tchk.adb

@@ -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- --
@@ -798,14 +798,9 @@ package body Tchk is
       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;