path: root/gcc/ada/par-ch3.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              P A R . C H 3                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

pragma Style_Checks (All_Checks);
--  Turn off subprogram body ordering check. Subprograms are in order
--  by RM section rather than alphabetical

with Sinfo.CN; use Sinfo.CN;

separate (Par)

package body Ch3 is

   -----------------------
   -- Local Subprograms --
   -----------------------

   function P_Component_List                               return Node_Id;
   function P_Defining_Character_Literal                   return Node_Id;
   function P_Delta_Constraint                             return Node_Id;
   function P_Derived_Type_Def_Or_Private_Ext_Decl         return Node_Id;
   function P_Digits_Constraint                            return Node_Id;
   function P_Discriminant_Association                     return Node_Id;
   function P_Enumeration_Literal_Specification            return Node_Id;
   function P_Enumeration_Type_Definition                  return Node_Id;
   function P_Fixed_Point_Definition                       return Node_Id;
   function P_Floating_Point_Definition                    return Node_Id;
   function P_Index_Or_Discriminant_Constraint             return Node_Id;
   function P_Real_Range_Specification_Opt                 return Node_Id;
   function P_Subtype_Declaration                          return Node_Id;
   function P_Type_Declaration                             return Node_Id;
   function P_Modular_Type_Definition                      return Node_Id;
   function P_Variant                                      return Node_Id;
   function P_Variant_Part                                 return Node_Id;

   procedure P_Declarative_Items
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean);
   --  Scans out a single declarative item, or, in the case of a declaration
   --  with a list of identifiers, a list of declarations, one for each of
   --  the identifiers in the list. The declaration or declarations scanned
   --  are appended to the given list. Done indicates whether or not there
   --  may be additional declarative items to scan. If Done is True, then
   --  a decision has been made that there are no more items to scan. If
   --  Done is False, then there may be additional declarations to scan.
   --  In_Spec is true if we are scanning a package declaration, and is used
   --  to generate an appropriate message if a statement is encountered in
   --  such a context.

   procedure P_Identifier_Declarations
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean);
   --  Scans out a set of declarations for an identifier or list of
   --  identifiers, and appends them to the given list. The parameters have
   --  the same significance as for P_Declarative_Items.

   procedure Statement_When_Declaration_Expected
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean);
   --  Called when a statement is found at a point where a declaration was
   --  expected. The parameters are as described for P_Declarative_Items.

   procedure Set_Declaration_Expected;
   --  Posts a "declaration expected" error messages at the start of the
   --  current token, and if this is the first such message issued, saves
   --  the message id in Missing_Begin_Msg, for possible later replacement.

   -------------------
   -- Init_Expr_Opt --
   -------------------

   function Init_Expr_Opt (P : Boolean := False) return Node_Id is
   begin
      if Token = Tok_Colon_Equal
        or else Token = Tok_Equal
        or else Token = Tok_Colon
        or else Token = Tok_Is
      then
         null;

      --  One other possibility. If we have a literal followed by a semicolon,
      --  we assume that we have a missing colon-equal.

      elsif Token in Token_Class_Literal then
         declare
            Scan_State : Saved_Scan_State;

         begin
            Save_Scan_State (Scan_State);
            Scan; -- past literal or identifier

            if Token = Tok_Semicolon then
               Restore_Scan_State (Scan_State);
            else
               Restore_Scan_State (Scan_State);
               return Empty;
            end if;
         end;

      --  Otherwise we definitely have no initialization expression

      else
         return Empty;
      end if;

      --  Merge here if we have an initialization expression

      T_Colon_Equal;

      if P then
         return P_Expression;
      else
         return P_Expression_No_Right_Paren;
      end if;
   end Init_Expr_Opt;

   ----------------------------
   -- 3.1  Basic Declaration --
   ----------------------------

   --  Parsed by P_Basic_Declarative_Items (3.9)

   ------------------------------
   -- 3.1  Defining Identifier --
   ------------------------------

   --  DEFINING_IDENTIFIER ::= IDENTIFIER

   --  Error recovery: can raise Error_Resync

   function P_Defining_Identifier return Node_Id is
      Ident_Node : Node_Id;

   begin
      --  Scan out the identifier. Note that this code is essentially identical
      --  to P_Identifier, except that in the call to Scan_Reserved_Identifier
      --  we set Force_Msg to True, since we want at least one message for each
      --  separate declaration (but not use) of a reserved identifier.

      if Token = Tok_Identifier then
         null;

      --  If we have a reserved identifier, manufacture an identifier with
      --  a corresponding name after posting an appropriate error message

      elsif Is_Reserved_Identifier then
         Scan_Reserved_Identifier (Force_Msg => True);

      --  Otherwise we have junk that cannot be interpreted as an identifier

      else
         T_Identifier; -- to give message
         raise Error_Resync;
      end if;

      Ident_Node := Token_Node;
      Scan; -- past the reserved identifier

      if Ident_Node /= Error then
         Change_Identifier_To_Defining_Identifier (Ident_Node);
      end if;

      return Ident_Node;
   end P_Defining_Identifier;

   -----------------------------
   -- 3.2.1  Type Declaration --
   -----------------------------

   --  TYPE_DECLARATION ::=
   --    FULL_TYPE_DECLARATION
   --  | INCOMPLETE_TYPE_DECLARATION
   --  | PRIVATE_TYPE_DECLARATION
   --  | PRIVATE_EXTENSION_DECLARATION

   --  FULL_TYPE_DECLARATION ::=
   --    type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
   --  | CONCURRENT_TYPE_DECLARATION

   --  INCOMPLETE_TYPE_DECLARATION ::=
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART];

   --  PRIVATE_TYPE_DECLARATION ::=
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
   --      is [abstract] [tagged] [limited] private;

   --  PRIVATE_EXTENSION_DECLARATION ::=
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
   --      [abstract] new ancestor_SUBTYPE_INDICATION with private;

   --  TYPE_DEFINITION ::=
   --    ENUMERATION_TYPE_DEFINITION  | INTEGER_TYPE_DEFINITION
   --  | REAL_TYPE_DEFINITION         | ARRAY_TYPE_DEFINITION
   --  | RECORD_TYPE_DEFINITION       | ACCESS_TYPE_DEFINITION
   --  | DERIVED_TYPE_DEFINITION

   --  INTEGER_TYPE_DEFINITION ::=
   --    SIGNED_INTEGER_TYPE_DEFINITION
   --    MODULAR_TYPE_DEFINITION

   --  Error recovery: can raise Error_Resync

   --  Note: The processing for full type declaration, incomplete type
   --  declaration, private type declaration and type definition is
   --  included in this function. The processing for concurrent type
   --  declarations is NOT here, but rather in chapter 9 (i.e. this
   --  function handles only declarations starting with TYPE).

   function P_Type_Declaration return Node_Id is
      Type_Loc         : Source_Ptr;
      Type_Start_Col   : Column_Number;
      Ident_Node       : Node_Id;
      Decl_Node        : Node_Id;
      Discr_List       : List_Id;
      Unknown_Dis      : Boolean;
      Discr_Sloc       : Source_Ptr;
      Abstract_Present : Boolean;
      Abstract_Loc     : Source_Ptr;
      End_Labl         : Node_Id;

      Typedef_Node : Node_Id;
      --  Normally holds type definition, except in the case of a private
      --  extension declaration, in which case it holds the declaration itself

   begin
      Type_Loc := Token_Ptr;
      Type_Start_Col := Start_Column;
      T_Type;
      Ident_Node := P_Defining_Identifier;
      Discr_Sloc := Token_Ptr;

      if P_Unknown_Discriminant_Part_Opt then
         Unknown_Dis := True;
         Discr_List := No_List;
      else
         Unknown_Dis := False;
         Discr_List := P_Known_Discriminant_Part_Opt;
      end if;

      --  Incomplete type declaration. We complete the processing for this
      --  case here and return the resulting incomplete type declaration node

      if Token = Tok_Semicolon then
         Scan; -- past ;
         Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
         Set_Defining_Identifier (Decl_Node, Ident_Node);
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
         Set_Discriminant_Specifications (Decl_Node, Discr_List);
         return Decl_Node;

      else
         Decl_Node := Empty;
      end if;

      --  Full type declaration or private type declaration, must have IS

      if Token = Tok_Equal then
         TF_Is;
         Scan; -- past = used in place of IS

      elsif Token = Tok_Renames then
         Error_Msg_SC ("RENAMES should be IS");
         Scan; -- past RENAMES used in place of IS

      else
         TF_Is;
      end if;

      --  First an error check, if we have two identifiers in a row, a likely
      --  possibility is that the first of the identifiers is an incorrectly
      --  spelled keyword.

      if Token = Tok_Identifier then
         declare
            SS : Saved_Scan_State;
            I2 : Boolean;

         begin
            Save_Scan_State (SS);
            Scan; -- past initial identifier
            I2 := (Token = Tok_Identifier);
            Restore_Scan_State (SS);

            if I2
              and then
                (Bad_Spelling_Of (Tok_Abstract) or else
                 Bad_Spelling_Of (Tok_Access)   or else
                 Bad_Spelling_Of (Tok_Aliased)  or else
                 Bad_Spelling_Of (Tok_Constant))
            then
               null;
            end if;
         end;
      end if;

      --  Check for misuse of Ada 95 keyword abstract in Ada 83 mode

      if Token_Name = Name_Abstract then
         Check_95_Keyword (Tok_Abstract, Tok_Tagged);
         Check_95_Keyword (Tok_Abstract, Tok_New);
      end if;

      --  Check cases of misuse of ABSTRACT

      if Token = Tok_Abstract then
         Abstract_Present := True;
         Abstract_Loc     := Token_Ptr;
         Scan; -- past ABSTRACT

         if 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

      if Token_Name = Name_Tagged then
         Check_95_Keyword (Tok_Tagged, Tok_Private);
         Check_95_Keyword (Tok_Tagged, Tok_Limited);
         Check_95_Keyword (Tok_Tagged, Tok_Record);
      end if;

      --  Special check for misuse of Aliased

      if Token = Tok_Aliased or else Token_Name = Name_Aliased then
         Error_Msg_SC ("ALIASED not allowed in type definition");
         Scan; -- past ALIASED
      end if;

      --  The following procesing deals with either a private type declaration
      --  or a full type declaration. In the private type case, we build the
      --  N_Private_Type_Declaration node, setting its Tagged_Present and
      --  Limited_Present flags, on encountering the Private keyword, and
      --  leave Typedef_Node set to Empty. For the full type declaration
      --  case, Typedef_Node gets set to the type definition.

      Typedef_Node := Empty;

      --  Switch on token following the IS. The loop normally runs once. It
      --  only runs more than once if an error is detected, to try again after
      --  detecting and fixing up the error.

      loop
         case Token is

            when Tok_Access =>
               Typedef_Node := P_Access_Type_Definition;
               TF_Semicolon;
               exit;

            when Tok_Array =>
               Typedef_Node := P_Array_Type_Definition;
               TF_Semicolon;
               exit;

            when Tok_Delta =>
               Typedef_Node := P_Fixed_Point_Definition;
               TF_Semicolon;
               exit;

            when Tok_Digits =>
               Typedef_Node := P_Floating_Point_Definition;
               TF_Semicolon;
               exit;

            when Tok_In =>
               Ignore (Tok_In);

            when Tok_Integer_Literal =>
               T_Range;
               Typedef_Node := P_Signed_Integer_Type_Definition;
               TF_Semicolon;
               exit;

            when Tok_Null =>
               Typedef_Node := P_Record_Definition;
               TF_Semicolon;
               exit;

            when Tok_Left_Paren =>
               Typedef_Node := P_Enumeration_Type_Definition;

               End_Labl :=
                 Make_Identifier (Token_Ptr,
                   Chars => Chars (Ident_Node));
               Set_Comes_From_Source (End_Labl, False);

               Set_End_Label (Typedef_Node, End_Labl);
               TF_Semicolon;
               exit;

            when Tok_Mod =>
               Typedef_Node := P_Modular_Type_Definition;
               TF_Semicolon;
               exit;

            when Tok_New =>
               Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
               TF_Semicolon;
               exit;

            when Tok_Range =>
               Typedef_Node := P_Signed_Integer_Type_Definition;
               TF_Semicolon;
               exit;

            when Tok_Record =>
               Typedef_Node := P_Record_Definition;

               End_Labl :=
                 Make_Identifier (Token_Ptr,
                   Chars => Chars (Ident_Node));
               Set_Comes_From_Source (End_Labl, False);

               Set_End_Label (Typedef_Node, End_Labl);
               TF_Semicolon;
               exit;

            when Tok_Tagged =>
               Scan; -- past TAGGED

               if Token = Tok_Abstract then
                  Error_Msg_SC ("ABSTRACT must come before TAGGED");
                  Abstract_Present := True;
                  Abstract_Loc := Token_Ptr;
                  Scan; -- past ABSTRACT
               end if;

               if Token = Tok_Limited then
                  Scan; -- past LIMITED

                  --  TAGGED LIMITED PRIVATE case

                  if Token = Tok_Private then
                     Decl_Node :=
                       New_Node (N_Private_Type_Declaration, Type_Loc);
                     Set_Tagged_Present (Decl_Node, True);
                     Set_Limited_Present (Decl_Node, True);
                     Scan; -- past PRIVATE

                  --  TAGGED LIMITED RECORD

                  else
                     Typedef_Node := P_Record_Definition;
                     Set_Tagged_Present (Typedef_Node, True);
                     Set_Limited_Present (Typedef_Node, True);

                     End_Labl :=
                       Make_Identifier (Token_Ptr,
                         Chars => Chars (Ident_Node));
                     Set_Comes_From_Source (End_Labl, False);

                     Set_End_Label (Typedef_Node, End_Labl);
                  end if;

               else
                  --  TAGGED PRIVATE

                  if Token = Tok_Private then
                     Decl_Node :=
                       New_Node (N_Private_Type_Declaration, Type_Loc);
                     Set_Tagged_Present (Decl_Node, True);
                     Scan; -- past PRIVATE

                  --  TAGGED RECORD

                  else
                     Typedef_Node := P_Record_Definition;
                     Set_Tagged_Present (Typedef_Node, True);

                     End_Labl :=
                       Make_Identifier (Token_Ptr,
                         Chars => Chars (Ident_Node));
                     Set_Comes_From_Source (End_Labl, False);

                     Set_End_Label (Typedef_Node, End_Labl);
                  end if;
               end if;

               TF_Semicolon;
               exit;

            when Tok_Private =>
               Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
               Scan; -- past PRIVATE
               TF_Semicolon;
               exit;

            when Tok_Limited =>
               Scan; -- past LIMITED

               loop
                  if Token = Tok_Tagged then
                     Error_Msg_SC ("TAGGED must come before LIMITED");
                     Scan; -- past TAGGED

                  elsif Token = Tok_Abstract then
                     Error_Msg_SC ("ABSTRACT must come before LIMITED");
                     Scan; -- past ABSTRACT

                  else
                     exit;
                  end if;
               end loop;

               --  LIMITED RECORD or LIMITED NULL RECORD

               if Token = Tok_Record or else Token = Tok_Null then
                  if Ada_83 then
                     Error_Msg_SP
                       ("(Ada 83) limited record declaration not allowed!");
                  end if;

                  Typedef_Node := P_Record_Definition;
                  Set_Limited_Present (Typedef_Node, True);

               --  LIMITED PRIVATE is the only remaining possibility here

               else
                  Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
                  Set_Limited_Present (Decl_Node, True);
                  T_Private; -- past PRIVATE (or complain if not there!)
               end if;

               TF_Semicolon;
               exit;

            --  Here we have an identifier after the IS, which is certainly
            --  wrong and which might be one of several different mistakes.

            when Tok_Identifier =>

               --  First case, if identifier is on same line, then probably we
               --  have something like "type X is Integer .." and the best
               --  diagnosis is a missing NEW. Note: the missing new message
               --  will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.

               if not Token_Is_At_Start_Of_Line then
                  Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
                  TF_Semicolon;

               --  If the identifier is at the start of the line, and is in the
               --  same column as the type declaration itself then we consider
               --  that we had a missing type definition on the previous line

               elsif Start_Column <= Type_Start_Col then
                  Error_Msg_AP ("type definition expected");
                  Typedef_Node := Error;

               --  If the identifier is at the start of the line, and is in
               --  a column to the right of the type declaration line, then we
               --  may have something like:

               --    type x is
               --       r : integer

               --  and the best diagnosis is a missing record keyword

               else
                  Typedef_Node := P_Record_Definition;
                  TF_Semicolon;
               end if;

               exit;

            --  Anything else is an error

            when others =>
               if Bad_Spelling_Of (Tok_Access)
                    or else
                  Bad_Spelling_Of (Tok_Array)
                    or else
                  Bad_Spelling_Of (Tok_Delta)
                    or else
                  Bad_Spelling_Of (Tok_Digits)
                    or else
                  Bad_Spelling_Of (Tok_Limited)
                    or else
                  Bad_Spelling_Of (Tok_Private)
                    or else
                  Bad_Spelling_Of (Tok_Range)
                    or else
                  Bad_Spelling_Of (Tok_Record)
                    or else
                  Bad_Spelling_Of (Tok_Tagged)
               then
                  null;

               else
                  Error_Msg_AP ("type definition expected");
                  raise Error_Resync;
               end if;

         end case;
      end loop;

      --  For the private type declaration case, the private type declaration
      --  node has been built, with the Tagged_Present and Limited_Present
      --  flags set as needed, and Typedef_Node is left set to Empty.

      if No (Typedef_Node) then
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
         Set_Abstract_Present (Decl_Node, Abstract_Present);

      --  For a private extension declaration, Typedef_Node contains the
      --  N_Private_Extension_Declaration node, which we now complete. Note
      --  that the private extension declaration, unlike a full type
      --  declaration, does permit unknown discriminants.

      elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
         Decl_Node := Typedef_Node;
         Set_Sloc (Decl_Node, Type_Loc);
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
         Set_Abstract_Present (Typedef_Node, Abstract_Present);

      --  In the full type declaration case, Typedef_Node has the type
      --  definition and here is where we build the full type declaration
      --  node. This is also where we check for improper use of an unknown
      --  discriminant part (not allowed for full type declaration).

      else
         if Nkind (Typedef_Node) = N_Record_Definition
           or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
                      and then Present (Record_Extension_Part (Typedef_Node)))
         then
            Set_Abstract_Present (Typedef_Node, Abstract_Present);

         elsif Abstract_Present then
            Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
         end if;

         Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
         Set_Type_Definition (Decl_Node, Typedef_Node);

         if Unknown_Dis then
            Error_Msg
              ("Full type declaration cannot have unknown discriminants",
                Discr_Sloc);
         end if;
      end if;

      --  Remaining processing is common for all three cases

      Set_Defining_Identifier (Decl_Node, Ident_Node);
      Set_Discriminant_Specifications (Decl_Node, Discr_List);
      return Decl_Node;

   end P_Type_Declaration;

   ----------------------------------
   -- 3.2.1  Full Type Declaration --
   ----------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   ----------------------------
   -- 3.2.1  Type Definition --
   ----------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   --------------------------------
   -- 3.2.2  Subtype Declaration --
   --------------------------------

   --  SUBTYPE_DECLARATION ::=
   --    subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;

   --  The caller has checked that the initial token is SUBTYPE

   --  Error recovery: can raise Error_Resync

   function P_Subtype_Declaration return Node_Id is
      Decl_Node : Node_Id;

   begin
      Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
      Scan; -- past SUBTYPE
      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
      TF_Is;

      if Token = Tok_New then
         Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
         Scan; -- past NEW
      end if;

      Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
      TF_Semicolon;
      return Decl_Node;
   end P_Subtype_Declaration;

   -------------------------------
   -- 3.2.2  Subtype Indication --
   -------------------------------

   --  SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]

   --  Error recovery: can raise Error_Resync

   function P_Subtype_Indication return Node_Id is
      Type_Node : Node_Id;

   begin
      if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
         Type_Node := P_Subtype_Mark;
         return P_Subtype_Indication (Type_Node);

      else
         --  Check for error of using record definition and treat it nicely,
         --  otherwise things are really messed up, so resynchronize.

         if Token = Tok_Record then
            Error_Msg_SC ("anonymous record definitions are not permitted");
            Discard_Junk_Node (P_Record_Definition);
            return Error;

         else
            Error_Msg_AP ("subtype indication expected");
            raise Error_Resync;
         end if;
      end if;
   end P_Subtype_Indication;

   --  The following function is identical except that it is called with
   --  the subtype mark already scanned out, and it scans out the constraint

   --  Error recovery: can raise Error_Resync

   function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is
      Indic_Node  : Node_Id;
      Constr_Node : Node_Id;

   begin
      Constr_Node := P_Constraint_Opt;

      if No (Constr_Node) then
         return Subtype_Mark;
      else
         Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
         Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
         Set_Constraint (Indic_Node, Constr_Node);
         return Indic_Node;
      end if;

   end P_Subtype_Indication;

   -------------------------
   -- 3.2.2  Subtype Mark --
   -------------------------

   --  SUBTYPE_MARK ::= subtype_NAME;

   --  Note: The subtype mark which appears after an IN or NOT IN
   --  operator is parsed by P_Range_Or_Subtype_Mark (3.5)

   --  Error recovery: cannot raise Error_Resync

   function P_Subtype_Mark return Node_Id is
   begin
      return P_Subtype_Mark_Resync;

   exception
      when Error_Resync =>
         return Error;
   end P_Subtype_Mark;

   --  This routine differs from P_Subtype_Mark in that it insists that an
   --  identifier be present, and if it is not, it raises Error_Resync.

   --  Error recovery: can raise Error_Resync

   function P_Subtype_Mark_Resync return Node_Id is
      Type_Node : Node_Id;

   begin
      if Token = Tok_Access then
         Error_Msg_SC ("anonymous access type definition not allowed here");
         Scan; -- past ACCESS
      end if;

      if Token = Tok_Array then
         Error_Msg_SC ("anonymous array definition not allowed here");
         Discard_Junk_Node (P_Array_Type_Definition);
         return Error;

      else
         Type_Node := P_Qualified_Simple_Name_Resync;

         --  Check for a subtype mark attribute. The only valid possibilities
         --  are 'CLASS and 'BASE. Anything else is a definite error. We may
         --  as well catch it here.

         if Token = Tok_Apostrophe then
            return P_Subtype_Mark_Attribute (Type_Node);
         else
            return Type_Node;
         end if;
      end if;
   end P_Subtype_Mark_Resync;

   --  The following function is called to scan out a subtype mark attribute.
   --  The caller has already scanned out the subtype mark, which is passed in
   --  as the argument, and has checked that the current token is apostrophe.

   --  Only a special subclass of attributes, called type attributes
   --  (see Snames package) are allowed in this syntactic position.

   --  Note: if the apostrophe is followed by other than an identifier, then
   --  the input expression is returned unchanged, and the scan pointer is
   --  left pointing to the apostrophe.

   --  Error recovery: can raise Error_Resync

   function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
      Attr_Node  : Node_Id := Empty;
      Scan_State : Saved_Scan_State;
      Prefix     : Node_Id;

   begin
      Prefix := Check_Subtype_Mark (Type_Node);

      if Prefix = Error then
         raise Error_Resync;
      end if;

      --  Loop through attributes appearing (more than one can appear as for
      --  for example in X'Base'Class). We are at an apostrophe on entry to
      --  this loop, and it runs once for each attribute parsed, with
      --  Prefix being the current possible prefix if it is an attribute.

      loop
         Save_Scan_State (Scan_State); -- at Apostrophe
         Scan; -- past apostrophe

         if Token /= Tok_Identifier then
            Restore_Scan_State (Scan_State); -- to apostrophe
            return Prefix; -- no attribute after all

         elsif not Is_Type_Attribute_Name (Token_Name) then
            Error_Msg_N
              ("attribute & may not be used in a subtype mark", Token_Node);
            raise Error_Resync;

         else
            Attr_Node :=
              Make_Attribute_Reference (Prev_Token_Ptr,
                Prefix => Prefix,
                Attribute_Name => Token_Name);
            Delete_Node (Token_Node);
            Scan; -- past type attribute identifier
         end if;

         exit when Token /= Tok_Apostrophe;
         Prefix := Attr_Node;
      end loop;

      --  Fall through here after scanning type attribute

      return Attr_Node;
   end P_Subtype_Mark_Attribute;

   -----------------------
   -- 3.2.2  Constraint --
   -----------------------

   --  CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT

   --  SCALAR_CONSTRAINT ::=
   --    RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT

   --  COMPOSITE_CONSTRAINT ::=
   --    INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT

   --  If no constraint is present, this function returns Empty

   --  Error recovery: can raise Error_Resync

   function P_Constraint_Opt return Node_Id is
   begin
      if Token = Tok_Range
        or else Bad_Spelling_Of (Tok_Range)
      then
         return P_Range_Constraint;

      elsif Token = Tok_Digits
        or else Bad_Spelling_Of (Tok_Digits)
      then
         return P_Digits_Constraint;

      elsif Token = Tok_Delta
        or else Bad_Spelling_Of (Tok_Delta)
      then
         return P_Delta_Constraint;

      elsif Token = Tok_Left_Paren then
         return P_Index_Or_Discriminant_Constraint;

      elsif Token = Tok_In then
         Ignore (Tok_In);
         return P_Constraint_Opt;

      else
         return Empty;
      end if;

   end P_Constraint_Opt;

   ------------------------------
   -- 3.2.2  Scalar Constraint --
   ------------------------------

   --  Parsed by P_Constraint_Opt (3.2.2)

   ---------------------------------
   -- 3.2.2  Composite Constraint --
   ---------------------------------

   --  Parsed by P_Constraint_Opt (3.2.2)

   --------------------------------------------------------
   -- 3.3  Identifier Declarations (Also 7.4, 8.5, 11.1) --
   --------------------------------------------------------

   --  This routine scans out a declaration starting with an identifier:

   --  OBJECT_DECLARATION ::=
   --    DEFINING_IDENTIFIER_LIST : [constant] [aliased]
   --      SUBTYPE_INDICATION [:= EXPRESSION];
   --  | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];

   --  NUMBER_DECLARATION ::=
   --    DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;

   --  OBJECT_RENAMING_DECLARATION ::=
   --    DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;

   --  EXCEPTION_RENAMING_DECLARATION ::=
   --    DEFINING_IDENTIFIER : exception renames exception_NAME;

   --  EXCEPTION_DECLARATION ::=
   --    DEFINING_IDENTIFIER_LIST : exception;

   --  Note that the ALIASED indication in an object declaration is
   --  marked by a flag in the parent node.

   --  The caller has checked that the initial token is an identifier

   --  The value returned is a list of declarations, one for each identifier
   --  in the list (as described in Sinfo, we always split up multiple
   --  declarations into the equivalent sequence of single declarations
   --  using the More_Ids and Prev_Ids flags to preserve the source).

   --  If the identifier turns out to be a probable statement rather than
   --  an identifier, then the scan is left pointing to the identifier and
   --  No_List is returned.

   --  Error recovery: can raise Error_Resync

   procedure P_Identifier_Declarations
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean)
   is
      Decl_Node  : Node_Id;
      Type_Node  : Node_Id;
      Ident_Sloc : Source_Ptr;
      Scan_State : Saved_Scan_State;
      List_OK    : Boolean := True;
      Ident      : Nat;
      Init_Expr  : Node_Id;
      Init_Loc   : Source_Ptr;
      Con_Loc    : Source_Ptr;

      Idents : array (Int range 1 .. 4096) of Entity_Id;
      --  Used to save identifiers in the identifier list. The upper bound
      --  of 4096 is expected to be infinite in practice, and we do not even
      --  bother to check if this upper bound is exceeded.

      Num_Idents : Nat := 1;
      --  Number of identifiers stored in Idents

      procedure No_List;
      --  This procedure is called in renames cases to make sure that we do
      --  not have more than one identifier. If we do have more than one
      --  then an error message is issued (and the declaration is split into
      --  multiple declarations)

      function Token_Is_Renames return Boolean;
      --  Checks if current token is RENAMES, and if so, scans past it and
      --  returns True, otherwise returns False. Includes checking for some
      --  common error cases.

      procedure No_List is
      begin
         if Num_Idents > 1 then
            Error_Msg ("identifier list not allowed for RENAMES",
                       Sloc (Idents (2)));
         end if;

         List_OK := False;
      end No_List;

      function Token_Is_Renames return Boolean is
         At_Colon : Saved_Scan_State;

      begin
         if Token = Tok_Colon then
            Save_Scan_State (At_Colon);
            Scan; -- past colon
            Check_Misspelling_Of (Tok_Renames);

            if Token = Tok_Renames then
               Error_Msg_SP ("extra "":"" ignored");
               Scan; -- past RENAMES
               return True;
            else
               Restore_Scan_State (At_Colon);
               return False;
            end if;

         else
            Check_Misspelling_Of (Tok_Renames);

            if Token = Tok_Renames then
               Scan; -- past RENAMES
               return True;
            else
               return False;
            end if;
         end if;
      end Token_Is_Renames;

   --  Start of processing for P_Identifier_Declarations

   begin
      Ident_Sloc := Token_Ptr;
      Save_Scan_State (Scan_State); -- at first identifier
      Idents (1) := P_Defining_Identifier;

      --  If we have a colon after the identifier, then we can assume that
      --  this is in fact a valid identifier declaration and can steam ahead.

      if Token = Tok_Colon then
         Scan; -- past colon

      --  If we have a comma, then scan out the list of identifiers

      elsif Token = Tok_Comma then

         while Comma_Present loop
            Num_Idents := Num_Idents + 1;
            Idents (Num_Idents) := P_Defining_Identifier;
         end loop;

         Save_Scan_State (Scan_State); -- at colon
         T_Colon;

      --  If we have identifier followed by := then we assume that what is
      --  really meant is an assignment statement. The assignment statement
      --  is scanned out and added to the list of declarations. An exception
      --  occurs if the := is followed by the keyword constant, in which case
      --  we assume it was meant to be a colon.

      elsif Token = Tok_Colon_Equal then
         Scan; -- past :=

         if Token = Tok_Constant then
            Error_Msg_SP ("colon expected");

         else
            Restore_Scan_State (Scan_State);
            Statement_When_Declaration_Expected (Decls, Done, In_Spec);
            return;
         end if;

      --  If we have an IS keyword, then assume the TYPE keyword was missing

      elsif Token = Tok_Is then
         Restore_Scan_State (Scan_State);
         Append_To (Decls, P_Type_Declaration);
         Done := False;
         return;

      --  Otherwise we have an error situation

      else
         Restore_Scan_State (Scan_State);

         --  First case is possible misuse of PROTECTED in Ada 83 mode. If
         --  so, fix the keyword and return to scan the protected declaration.

         if Token_Name = Name_Protected then
            Check_95_Keyword (Tok_Protected, Tok_Identifier);
            Check_95_Keyword (Tok_Protected, Tok_Type);
            Check_95_Keyword (Tok_Protected, Tok_Body);

            if Token = Tok_Protected then
               Done := False;
               return;
            end if;

         --  Check misspelling possibilities. If so, correct the misspelling
         --  and return to scan out the resulting declaration.

         elsif Bad_Spelling_Of (Tok_Function)
           or else Bad_Spelling_Of (Tok_Procedure)
           or else Bad_Spelling_Of (Tok_Package)
           or else Bad_Spelling_Of (Tok_Pragma)
           or else Bad_Spelling_Of (Tok_Protected)
           or else Bad_Spelling_Of (Tok_Generic)
           or else Bad_Spelling_Of (Tok_Subtype)
           or else Bad_Spelling_Of (Tok_Type)
           or else Bad_Spelling_Of (Tok_Task)
           or else Bad_Spelling_Of (Tok_Use)
           or else Bad_Spelling_Of (Tok_For)
         then
            Done := False;
            return;

         --  Otherwise we definitely have an ordinary identifier with a junk
         --  token after it. Just complain that we expect a declaration, and
         --  skip to a semicolon

         else
            Set_Declaration_Expected;
            Resync_Past_Semicolon;
            Done := False;
            return;
         end if;
      end if;

      --  Come here with an identifier list and colon scanned out. We now
      --  build the nodes for the declarative items. One node is built for
      --  each identifier in the list, with the type information being
      --  repeated by rescanning the appropriate section of source.

      --  First an error check, if we have two identifiers in a row, a likely
      --  possibility is that the first of the identifiers is an incorrectly
      --  spelled keyword.

      if Token = Tok_Identifier then
         declare
            SS : Saved_Scan_State;
            I2 : Boolean;

         begin
            Save_Scan_State (SS);
            Scan; -- past initial identifier
            I2 := (Token = Tok_Identifier);
            Restore_Scan_State (SS);

            if I2
              and then
                (Bad_Spelling_Of (Tok_Access)   or else
                 Bad_Spelling_Of (Tok_Aliased)  or else
                 Bad_Spelling_Of (Tok_Constant))
            then
               null;
            end if;
         end;
      end if;

      --  Loop through identifiers

      Ident := 1;
      Ident_Loop : loop

         --  Check for some cases of misused Ada 95 keywords

         if Token_Name = Name_Aliased then
            Check_95_Keyword (Tok_Aliased, Tok_Array);
            Check_95_Keyword (Tok_Aliased, Tok_Identifier);
            Check_95_Keyword (Tok_Aliased, Tok_Constant);
         end if;

         --  Constant cases

         if Token = Tok_Constant then
            Con_Loc := Token_Ptr;
            Scan; -- past CONSTANT

            --  Number declaration, initialization required

            Init_Expr := Init_Expr_Opt;

            if Present (Init_Expr) then
               Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
               Set_Expression (Decl_Node, Init_Expr);

            --  Constant object declaration

            else
               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
               Set_Constant_Present (Decl_Node, True);

               if Token_Name = Name_Aliased then
                  Check_95_Keyword (Tok_Aliased, Tok_Array);
                  Check_95_Keyword (Tok_Aliased, Tok_Identifier);
               end if;

               if Token = Tok_Aliased then
                  Error_Msg_SC ("ALIASED should be before CONSTANT");
                  Scan; -- past ALIASED
                  Set_Aliased_Present (Decl_Node, True);
               end if;

               if Token = Tok_Array then
                  Set_Object_Definition
                    (Decl_Node, P_Array_Type_Definition);
               else
                  Set_Object_Definition (Decl_Node, P_Subtype_Indication);
               end if;

               if Token = Tok_Renames then
                  Error_Msg
                    ("CONSTANT not permitted in renaming declaration",
                     Con_Loc);
                  Scan; -- Past renames
                  Discard_Junk_Node (P_Name);
               end if;
            end if;

         --  Exception cases

         elsif Token = Tok_Exception then
            Scan; -- past EXCEPTION

            if Token_Is_Renames then
               No_List;
               Decl_Node :=
                 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
               Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
               No_Constraint;
            else
               Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
            end if;

         --  Aliased case (note that an object definition is required)

         elsif Token = Tok_Aliased then
            Scan; -- past ALIASED
            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
            Set_Aliased_Present (Decl_Node, True);

            if Token = Tok_Constant then
               Scan; -- past CONSTANT
               Set_Constant_Present (Decl_Node, True);
            end if;

            if Token = Tok_Array then
               Set_Object_Definition
                 (Decl_Node, P_Array_Type_Definition);
            else
               Set_Object_Definition (Decl_Node, P_Subtype_Indication);
            end if;

         --  Array case

         elsif Token = Tok_Array then
            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
            Set_Object_Definition (Decl_Node, P_Array_Type_Definition);

         --  Subtype indication case

         else
            Type_Node := P_Subtype_Mark;

            --  Object renaming declaration

            if Token_Is_Renames then
               No_List;
               Decl_Node :=
                 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
               Set_Subtype_Mark (Decl_Node, Type_Node);
               Set_Name (Decl_Node, P_Name);

            --  Object declaration

            else
               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
               Set_Object_Definition
                 (Decl_Node, P_Subtype_Indication (Type_Node));

               --  RENAMES at this point means that we had the combination of
               --  a constraint on the Type_Node and renames, which is illegal

               if Token_Is_Renames then
                  Error_Msg_N
                    ("constraint not allowed in object renaming declaration",
                     Constraint (Object_Definition (Decl_Node)));
                  raise Error_Resync;
               end if;
            end if;
         end if;

         --  Scan out initialization, allowed only for object declaration

         Init_Loc := Token_Ptr;
         Init_Expr := Init_Expr_Opt;

         if Present (Init_Expr) then
            if Nkind (Decl_Node) = N_Object_Declaration then
               Set_Expression (Decl_Node, Init_Expr);
            else
               Error_Msg ("initialization not allowed here", Init_Loc);
            end if;
         end if;

         TF_Semicolon;
         Set_Defining_Identifier (Decl_Node, Idents (Ident));

         if List_OK then
            if Ident < Num_Idents then
               Set_More_Ids (Decl_Node, True);
            end if;

            if Ident > 1 then
               Set_Prev_Ids (Decl_Node, True);
            end if;
         end if;

         Append (Decl_Node, Decls);
         exit Ident_Loop when Ident = Num_Idents;
         Restore_Scan_State (Scan_State);
         T_Colon;
         Ident := Ident + 1;
      end loop Ident_Loop;

      Done := False;

   end P_Identifier_Declarations;

   -------------------------------
   -- 3.3.1  Object Declaration --
   -------------------------------

   --  OBJECT DECLARATION ::=
   --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
   --      SUBTYPE_INDICATION [:= EXPRESSION];
   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];
   --  | SINGLE_TASK_DECLARATION
   --  | SINGLE_PROTECTED_DECLARATION

   --  Cases starting with TASK are parsed by P_Task (9.1)
   --  Cases starting with PROTECTED are parsed by P_Protected (9.4)
   --  All other cases are parsed by P_Identifier_Declarations (3.3)

   -------------------------------------
   -- 3.3.1  Defining Identifier List --
   -------------------------------------

   --  DEFINING_IDENTIFIER_LIST ::=
   --    DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}

   --  Always parsed by the construct in which it appears. See special
   --  section on "Handling of Defining Identifier Lists" in this unit.

   -------------------------------
   -- 3.3.2  Number Declaration --
   -------------------------------

   --  Parsed by P_Identifier_Declarations (3.3)

   -------------------------------------------------------------------------
   -- 3.4  Derived Type Definition or Private Extension Declaration (7.3) --
   -------------------------------------------------------------------------

   --  DERIVED_TYPE_DEFINITION ::=
   --    [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]

   --  PRIVATE_EXTENSION_DECLARATION ::=
   --     type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
   --       [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;

   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION

   --  The caller has already scanned out the part up to the NEW, and Token
   --  either contains Tok_New (or ought to, if it doesn't this procedure
   --  will post an appropriate "NEW expected" message).

   --  Note: the caller is responsible for filling in the Sloc field of
   --  the returned node in the private extension declaration case as
   --  well as the stuff relating to the discriminant part.

   --  Error recovery: can raise Error_Resync;

   function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
      Typedef_Node  : Node_Id;
      Typedecl_Node : Node_Id;

   begin
      Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
      T_New;

      if Token = Tok_Abstract then
         Error_Msg_SC ("ABSTRACT must come before NEW, not after");
         Scan;
      end if;

      Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication);

      --  Deal with record extension, note that we assume that a WITH is
      --  missing in the case of "type X is new Y record ..." or in the
      --  case of "type X is new Y null record".

      if Token = Tok_With
        or else Token = Tok_Record
        or else Token = Tok_Null
      then
         T_With; -- past WITH or give error message

         if Token = Tok_Limited then
            Error_Msg_SC
              ("LIMITED keyword not allowed in private extension");
            Scan; -- ignore LIMITED
         end if;

         --  Private extension declaration

         if Token = Tok_Private then
            Scan; -- past PRIVATE

            --  Throw away the type definition node and build the type
            --  declaration node. Note the caller must set the Sloc,
            --  Discriminant_Specifications, Unknown_Discriminants_Present,
            --  and Defined_Identifier fields in the returned node.

            Typedecl_Node :=
              Make_Private_Extension_Declaration (No_Location,
                Defining_Identifier => Empty,
                Subtype_Indication  => Subtype_Indication (Typedef_Node),
                Abstract_Present    => Abstract_Present (Typedef_Node));

            Delete_Node (Typedef_Node);
            return Typedecl_Node;

         --  Derived type definition with record extension part

         else
            Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
            return Typedef_Node;
         end if;

      --  Derived type definition with no record extension part

      else
         return Typedef_Node;
      end if;
   end P_Derived_Type_Def_Or_Private_Ext_Decl;

   ---------------------------
   -- 3.5  Range Constraint --
   ---------------------------

   --  RANGE_CONSTRAINT ::= range RANGE

   --  The caller has checked that the initial token is RANGE

   --  Error recovery: cannot raise Error_Resync

   function P_Range_Constraint return Node_Id is
      Range_Node : Node_Id;

   begin
      Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
      Scan; -- past RANGE
      Set_Range_Expression (Range_Node, P_Range);
      return Range_Node;
   end P_Range_Constraint;

   ----------------
   -- 3.5  Range --
   ----------------

   --  RANGE ::=
   --    RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION

   --  Note: the range that appears in a membership test is parsed by
   --  P_Range_Or_Subtype_Mark (3.5).

   --  Error recovery: cannot raise Error_Resync

   function P_Range return Node_Id is
      Expr_Node  : Node_Id;
      Range_Node : Node_Id;

   begin
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;

      if Expr_Form = EF_Range_Attr then
         return Expr_Node;

      elsif Token = Tok_Dot_Dot then
         Range_Node := New_Node (N_Range, Token_Ptr);
         Set_Low_Bound (Range_Node, Expr_Node);
         Scan; -- past ..
         Expr_Node := P_Expression;
         Check_Simple_Expression (Expr_Node);
         Set_High_Bound (Range_Node, Expr_Node);
         return Range_Node;

      --  Anything else is an error

      else
         T_Dot_Dot; -- force missing .. message
         return Error;
      end if;
   end P_Range;

   ----------------------------------
   -- 3.5  P_Range_Or_Subtype_Mark --
   ----------------------------------

   --  RANGE ::=
   --    RANGE_ATTRIBUTE_REFERENCE
   --  | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION

   --  This routine scans out the range or subtype mark that forms the right
   --  operand of a membership test.

   --  Note: as documented in the Sinfo interface, although the syntax only
   --  allows a subtype mark, we in fact allow any simple expression to be
   --  returned from this routine. The semantics is responsible for issuing
   --  an appropriate message complaining if the argument is not a name.
   --  This simplifies the coding and error recovery processing in the
   --  parser, and in any case it is preferable not to consider this a
   --  syntax error and to continue with the semantic analysis.

   --  Error recovery: cannot raise Error_Resync

   function P_Range_Or_Subtype_Mark return Node_Id is
      Expr_Node  : Node_Id;
      Range_Node : Node_Id;

   begin
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;

      if Expr_Form = EF_Range_Attr then
         return Expr_Node;

      --  Simple_Expression .. Simple_Expression

      elsif Token = Tok_Dot_Dot then
         Check_Simple_Expression (Expr_Node);
         Range_Node := New_Node (N_Range, Token_Ptr);
         Set_Low_Bound (Range_Node, Expr_Node);
         Scan; -- past ..
         Set_High_Bound (Range_Node, P_Simple_Expression);
         return Range_Node;

      --  Case of subtype mark (optionally qualified simple name or an
      --  attribute whose prefix is an optionally qualifed simple name)

      elsif Expr_Form = EF_Simple_Name
        or else Nkind (Expr_Node) = N_Attribute_Reference
      then
         --  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");
            Scan; -- past RANGE
            raise Error_Resync;

         --  Check for error of DIGITS or DELTA after a subtype mark

         elsif Token = Tok_Digits or else Token = Tok_Delta then
            Error_Msg_SC
               ("accuracy definition not allowed in membership test");
            Scan; -- past DIGITS or DELTA
            raise Error_Resync;

         elsif Token = Tok_Apostrophe then
            return P_Subtype_Mark_Attribute (Expr_Node);

         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!

      else
         return Expr_Node;
      end if;
   end P_Range_Or_Subtype_Mark;

   ----------------------------------------
   -- 3.5.1  Enumeration Type Definition --
   ----------------------------------------

   --  ENUMERATION_TYPE_DEFINITION ::=
   --    (ENUMERATION_LITERAL_SPECIFICATION
   --      {, ENUMERATION_LITERAL_SPECIFICATION})

   --  The caller has already scanned out the TYPE keyword

   --  Error recovery: can raise Error_Resync;

   function P_Enumeration_Type_Definition return Node_Id is
      Typedef_Node : Node_Id;

   begin
      Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
      Set_Literals (Typedef_Node, New_List);

      T_Left_Paren;

      loop
         Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
         exit when not Comma_Present;
      end loop;

      T_Right_Paren;
      return Typedef_Node;
   end P_Enumeration_Type_Definition;

   ----------------------------------------------
   -- 3.5.1  Enumeration Literal Specification --
   ----------------------------------------------

   --  ENUMERATION_LITERAL_SPECIFICATION ::=
   --    DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL

   --  Error recovery: can raise Error_Resync

   function P_Enumeration_Literal_Specification return Node_Id is
   begin
      if Token = Tok_Char_Literal then
         return P_Defining_Character_Literal;
      else
         return P_Defining_Identifier;
      end if;
   end P_Enumeration_Literal_Specification;

   ---------------------------------------
   -- 3.5.1  Defining_Character_Literal --
   ---------------------------------------

   --  DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL

   --  Error recovery: cannot raise Error_Resync

   --  The caller has checked that the current token is a character literal

   function P_Defining_Character_Literal return Node_Id is
      Literal_Node : Node_Id;

   begin
      Literal_Node := Token_Node;
      Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
      Scan; -- past character literal
      return Literal_Node;
   end P_Defining_Character_Literal;

   ------------------------------------
   -- 3.5.4  Integer Type Definition --
   ------------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   -------------------------------------------
   -- 3.5.4  Signed Integer Type Definition --
   -------------------------------------------

   --  SIGNED_INTEGER_TYPE_DEFINITION ::=
   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION

   --  Normally the initial token on entry is RANGE, but in some
   --  error conditions, the range token was missing and control is
   --  passed with Token pointing to first token of the first expression.

   --  Error recovery: cannot raise Error_Resync

   function P_Signed_Integer_Type_Definition return Node_Id is
      Typedef_Node : Node_Id;
      Expr_Node    : Node_Id;

   begin
      Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);

      if Token = Tok_Range then
         Scan; -- past RANGE
      end if;

      Expr_Node := P_Expression;
      Check_Simple_Expression (Expr_Node);
      Set_Low_Bound (Typedef_Node, Expr_Node);
      T_Dot_Dot;
      Expr_Node := P_Expression;
      Check_Simple_Expression (Expr_Node);
      Set_High_Bound (Typedef_Node, Expr_Node);
      return Typedef_Node;
   end P_Signed_Integer_Type_Definition;

   ------------------------------------
   -- 3.5.4  Modular Type Definition --
   ------------------------------------

   --  MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION

   --  The caller has checked that the initial token is MOD

   --  Error recovery: cannot raise Error_Resync

   function P_Modular_Type_Definition return Node_Id is
      Typedef_Node : Node_Id;

   begin
      if Ada_83 then
         Error_Msg_SC ("(Ada 83): modular types not allowed");
      end if;

      Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
      Scan; -- past MOD
      Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);

      --  Handle mod L..R cleanly

      if Token = Tok_Dot_Dot then
         Error_Msg_SC ("range not allowed for modular type");
         Scan; -- past ..
         Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
      end if;

      return Typedef_Node;
   end P_Modular_Type_Definition;

   ---------------------------------
   -- 3.5.6  Real Type Definition --
   ---------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   --------------------------------------
   -- 3.5.7  Floating Point Definition --
   --------------------------------------

   --  FLOATING_POINT_DEFINITION ::=
   --    digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]

   --  Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION

   --  The caller has checked that the initial token is DIGITS

   --  Error recovery: cannot raise Error_Resync

   function P_Floating_Point_Definition return Node_Id is
      Digits_Loc : constant Source_Ptr := Token_Ptr;
      Def_Node   : Node_Id;
      Expr_Node  : Node_Id;

   begin
      Scan; -- past DIGITS
      Expr_Node := P_Expression_No_Right_Paren;
      Check_Simple_Expression_In_Ada_83 (Expr_Node);

      --  Handle decimal fixed-point defn with DIGITS/DELTA in wrong order

      if Token = Tok_Delta then
         Error_Msg_SC ("DELTA must come before DIGITS");
         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
         Scan; -- past DELTA
         Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);

      --  OK floating-point definition

      else
         Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
      end if;

      Set_Digits_Expression (Def_Node, Expr_Node);
      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
      return Def_Node;
   end P_Floating_Point_Definition;

   -------------------------------------
   -- 3.5.7  Real Range Specification --
   -------------------------------------

   --  REAL_RANGE_SPECIFICATION ::=
   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION

   --  Error recovery: cannot raise Error_Resync

   function P_Real_Range_Specification_Opt return Node_Id is
      Specification_Node : Node_Id;
      Expr_Node          : Node_Id;

   begin
      if Token = Tok_Range then
         Specification_Node :=
           New_Node (N_Real_Range_Specification, Token_Ptr);
         Scan; -- past RANGE
         Expr_Node := P_Expression_No_Right_Paren;
         Check_Simple_Expression (Expr_Node);
         Set_Low_Bound (Specification_Node, Expr_Node);
         T_Dot_Dot;
         Expr_Node := P_Expression_No_Right_Paren;
         Check_Simple_Expression (Expr_Node);
         Set_High_Bound (Specification_Node, Expr_Node);
         return Specification_Node;
      else
         return Empty;
      end if;
   end P_Real_Range_Specification_Opt;

   -----------------------------------
   -- 3.5.9  Fixed Point Definition --
   -----------------------------------

   --  FIXED_POINT_DEFINITION ::=
   --    ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION

   --  ORDINARY_FIXED_POINT_DEFINITION ::=
   --    delta static_EXPRESSION REAL_RANGE_SPECIFICATION

   --  DECIMAL_FIXED_POINT_DEFINITION ::=
   --    delta static_EXPRESSION
   --      digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]

   --  The caller has checked that the initial token is DELTA

   --  Error recovery: cannot raise Error_Resync

   function P_Fixed_Point_Definition return Node_Id is
      Delta_Node : Node_Id;
      Delta_Loc  : Source_Ptr;
      Def_Node   : Node_Id;
      Expr_Node  : Node_Id;

   begin
      Delta_Loc := Token_Ptr;
      Scan; -- past DELTA
      Delta_Node := P_Expression_No_Right_Paren;
      Check_Simple_Expression_In_Ada_83 (Delta_Node);

      if Token = Tok_Digits then
         if Ada_83 then
            Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
         end if;

         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
         Scan; -- past DIGITS
         Expr_Node := P_Expression_No_Right_Paren;
         Check_Simple_Expression_In_Ada_83 (Expr_Node);
         Set_Digits_Expression (Def_Node, Expr_Node);

      else
         Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);

         --  Range is required in ordinary fixed point case

         if Token /= Tok_Range then
            Error_Msg_AP ("range must be given for fixed-point type");
            T_Range;
         end if;
      end if;

      Set_Delta_Expression (Def_Node, Delta_Node);
      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
      return Def_Node;
   end P_Fixed_Point_Definition;

   --------------------------------------------
   -- 3.5.9  Ordinary Fixed Point Definition --
   --------------------------------------------

   --  Parsed by P_Fixed_Point_Definition (3.5.9)

   -------------------------------------------
   -- 3.5.9  Decimal Fixed Point Definition --
   -------------------------------------------

   --  Parsed by P_Decimal_Point_Definition (3.5.9)

   ------------------------------
   -- 3.5.9  Digits Constraint --
   ------------------------------

   --  DIGITS_CONSTRAINT ::=
   --    digits static_EXPRESSION [RANGE_CONSTRAINT]

   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION

   --  The caller has checked that the initial token is DIGITS

   function P_Digits_Constraint return Node_Id is
      Constraint_Node : Node_Id;
      Expr_Node : Node_Id;

   begin
      Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
      Scan; -- past DIGITS
      Expr_Node := P_Expression_No_Right_Paren;
      Check_Simple_Expression_In_Ada_83 (Expr_Node);
      Set_Digits_Expression (Constraint_Node, Expr_Node);

      if Token = Tok_Range then
         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
      end if;

      return Constraint_Node;
   end P_Digits_Constraint;

   -----------------------------
   -- 3.5.9  Delta Constraint --
   -----------------------------

   --  DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]

   --  Note: this is an obsolescent feature in Ada 95 (I.3)

   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION

   --  The caller has checked that the initial token is DELTA

   --  Error recovery: cannot raise Error_Resync

   function P_Delta_Constraint return Node_Id is
      Constraint_Node : Node_Id;
      Expr_Node : Node_Id;

   begin
      Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
      Scan; -- past DELTA
      Expr_Node := P_Expression_No_Right_Paren;
      Check_Simple_Expression_In_Ada_83 (Expr_Node);
      Set_Delta_Expression (Constraint_Node, Expr_Node);

      if Token = Tok_Range then
         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
      end if;

      return Constraint_Node;
   end P_Delta_Constraint;

   --------------------------------
   -- 3.6  Array Type Definition --
   --------------------------------

   --  ARRAY_TYPE_DEFINITION ::=
   --    UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION

   --  UNCONSTRAINED_ARRAY_DEFINITION ::=
   --    array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
   --      COMPONENT_DEFINITION

   --  INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>

   --  CONSTRAINED_ARRAY_DEFINITION ::=
   --    array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
   --      COMPONENT_DEFINITION

   --  DISCRETE_SUBTYPE_DEFINITION ::=
   --    DISCRETE_SUBTYPE_INDICATION | RANGE

   --  COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION

   --  The caller has checked that the initial token is ARRAY

   --  Error recovery: can raise Error_Resync

   function P_Array_Type_Definition return Node_Id is
      Array_Loc  : Source_Ptr;
      Def_Node   : Node_Id;
      Subs_List  : List_Id;
      Scan_State : Saved_Scan_State;

   begin
      Array_Loc := Token_Ptr;
      Scan; -- past ARRAY
      Subs_List := New_List;
      T_Left_Paren;

      --  It's quite tricky to disentangle these two possibilities, so we do
      --  a prescan to determine which case we have and then reset the scan.
      --  The prescan skips past possible subtype mark tokens.

      Save_Scan_State (Scan_State); -- just after paren

      while Token in Token_Class_Desig or else
            Token = Tok_Dot or else
            Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
      loop
         Scan;
      end loop;

      --  If we end up on RANGE <> then we have the unconstrained case. We
      --  will also allow the RANGE to be omitted, just to improve error
      --  handling for a case like array (integer <>) of integer;

      Scan; -- past possible RANGE or <>

      if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
         Prev_Token = Tok_Box
      then
         Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
         Restore_Scan_State (Scan_State); -- to first subtype mark

         loop
            Append (P_Subtype_Mark_Resync, Subs_List);
            T_Range;
            T_Box;
            exit when Token = Tok_Right_Paren or else Token = Tok_Of;
            T_Comma;
         end loop;

         Set_Subtype_Marks (Def_Node, Subs_List);

      else
         Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
         Restore_Scan_State (Scan_State); -- to first discrete range

         loop
            Append (P_Discrete_Subtype_Definition, Subs_List);
            exit when not Comma_Present;
         end loop;

         Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
      end if;

      T_Right_Paren;
      T_Of;

      if Token = Tok_Aliased then
         Set_Aliased_Present (Def_Node, True);
         Scan; -- past ALIASED
      end if;

      Set_Subtype_Indication (Def_Node, P_Subtype_Indication);
      return Def_Node;
   end P_Array_Type_Definition;

   -----------------------------------------
   -- 3.6  Unconstrained Array Definition --
   -----------------------------------------

   --  Parsed by P_Array_Type_Definition (3.6)

   ---------------------------------------
   -- 3.6  Constrained Array Definition --
   ---------------------------------------

   --  Parsed by P_Array_Type_Definition (3.6)

   --------------------------------------
   -- 3.6  Discrete Subtype Definition --
   --------------------------------------

   --  DISCRETE_SUBTYPE_DEFINITION ::=
   --    discrete_SUBTYPE_INDICATION | RANGE

   --  Note: the discrete subtype definition appearing in a constrained
   --  array definition is parsed by P_Array_Type_Definition (3.6)

   --  Error recovery: cannot raise Error_Resync

   function P_Discrete_Subtype_Definition return Node_Id is
   begin

      --  The syntax of a discrete subtype definition is identical to that
      --  of a discrete range, so we simply share the same parsing code.

      return P_Discrete_Range;
   end P_Discrete_Subtype_Definition;

   -------------------------------
   -- 3.6  Component Definition --
   -------------------------------

   --  For the array case, parsed by P_Array_Type_Definition (3.6)
   --  For the record case, parsed by P_Component_Declaration (3.8)

   -----------------------------
   -- 3.6.1  Index Constraint --
   -----------------------------

   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)

   ---------------------------
   -- 3.6.1  Discrete Range --
   ---------------------------

   --  DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE

   --  The possible forms for a discrete range are:

      --   Subtype_Mark                           (SUBTYPE_INDICATION, 3.2.2)
      --   Subtype_Mark range Range               (SUBTYPE_INDICATION, 3.2.2)
      --   Range_Attribute                        (RANGE, 3.5)
      --   Simple_Expression .. Simple_Expression (RANGE, 3.5)

   --  Error recovery: cannot raise Error_Resync

   function P_Discrete_Range return Node_Id is
      Expr_Node  : Node_Id;
      Range_Node : Node_Id;

   begin
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;

      if Expr_Form = EF_Range_Attr then
         return Expr_Node;

      elsif Token = Tok_Range then
         if Expr_Form /= EF_Simple_Name then
            Error_Msg_SC ("range must be preceded by subtype mark");
         end if;

         return P_Subtype_Indication (Expr_Node);

      --  Check Expression .. Expression case

      elsif Token = Tok_Dot_Dot then
         Range_Node := New_Node (N_Range, Token_Ptr);
         Set_Low_Bound (Range_Node, Expr_Node);
         Scan; -- past ..
         Expr_Node := P_Expression;
         Check_Simple_Expression (Expr_Node);
         Set_High_Bound (Range_Node, Expr_Node);
         return Range_Node;

      --  Otherwise we must have a subtype mark

      elsif Expr_Form = EF_Simple_Name then
         return Expr_Node;

      --  If incorrect, complain that we expect ..

      else
         T_Dot_Dot;
         return Expr_Node;
      end if;
   end P_Discrete_Range;

   ----------------------------
   -- 3.7  Discriminant Part --
   ----------------------------

   --  DISCRIMINANT_PART ::=
   --    UNKNOWN_DISCRIMINANT_PART
   --  | KNOWN_DISCRIMINANT_PART

   --  A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
   --  or P_Unknown_Discriminant_Part (3.7), since we know which we want.

   ------------------------------------
   -- 3.7  Unknown Discriminant Part --
   ------------------------------------

   --  UNKNOWN_DISCRIMINANT_PART ::= (<>)

   --  If no unknown discriminant part is present, then False is returned,
   --  otherwise the unknown discriminant is scanned out and True is returned.

   --  Error recovery: cannot raise Error_Resync

   function P_Unknown_Discriminant_Part_Opt return Boolean is
      Scan_State : Saved_Scan_State;

   begin
      if Token /= Tok_Left_Paren then
         return False;

      else
         Save_Scan_State (Scan_State);
         Scan; -- past the left paren

         if Token = Tok_Box then

            if Ada_83 then
               Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
            end if;

            Scan; -- past the box
            T_Right_Paren; -- must be followed by right paren
            return True;

         else
            Restore_Scan_State (Scan_State);
            return False;
         end if;
      end if;
   end P_Unknown_Discriminant_Part_Opt;

   ----------------------------------
   -- 3.7  Known Discriminant Part --
   ----------------------------------

   --  KNOWN_DISCRIMINANT_PART ::=
   --    (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})

   --  DISCRIMINANT_SPECIFICATION ::=
   --    DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
   --      [:= DEFAULT_EXPRESSION]
   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
   --      [:= DEFAULT_EXPRESSION]

   --  If no known discriminant part is present, then No_List is returned

   --  Error recovery: cannot raise Error_Resync

   function P_Known_Discriminant_Part_Opt return List_Id is
      Specification_Node : Node_Id;
      Specification_List : List_Id;
      Ident_Sloc         : Source_Ptr;
      Scan_State         : Saved_Scan_State;
      Num_Idents         : Nat;
      Ident              : Nat;

      Idents : array (Int range 1 .. 4096) of Entity_Id;
      --  This array holds the list of defining identifiers. The upper bound
      --  of 4096 is intended to be essentially infinite, and we do not even
      --  bother to check for it being exceeded.

   begin
      if Token = Tok_Left_Paren then
         Specification_List := New_List;
         Scan; -- past (
         P_Pragmas_Misplaced;

         Specification_Loop : loop

            Ident_Sloc := Token_Ptr;
            Idents (1) := P_Defining_Identifier;
            Num_Idents := 1;

            while Comma_Present loop
               Num_Idents := Num_Idents + 1;
               Idents (Num_Idents) := P_Defining_Identifier;
            end loop;

            T_Colon;

            --  If there are multiple identifiers, we repeatedly scan the
            --  type and initialization expression information by resetting
            --  the scan pointer (so that we get completely separate trees
            --  for each occurrence).

            if Num_Idents > 1 then
               Save_Scan_State (Scan_State);
            end if;

            --  Loop through defining identifiers in list

            Ident := 1;
            Ident_Loop : loop
               Specification_Node :=
                 New_Node (N_Discriminant_Specification, Ident_Sloc);
               Set_Defining_Identifier (Specification_Node, Idents (Ident));

               if Token = Tok_Access then
                  if Ada_83 then
                     Error_Msg_SC
                       ("(Ada 83) access discriminant not allowed!");
                  end if;

                  Set_Discriminant_Type
                    (Specification_Node, P_Access_Definition);
               else
                  Set_Discriminant_Type
                    (Specification_Node, P_Subtype_Mark);
                  No_Constraint;
               end if;

               Set_Expression
                 (Specification_Node, Init_Expr_Opt (True));

               if Ident > 1 then
                  Set_Prev_Ids (Specification_Node, True);
               end if;

               if Ident < Num_Idents then
                  Set_More_Ids (Specification_Node, True);
               end if;

               Append (Specification_Node, Specification_List);
               exit Ident_Loop when Ident = Num_Idents;
               Ident := Ident + 1;
               Restore_Scan_State (Scan_State);
            end loop Ident_Loop;

            exit Specification_Loop when Token /= Tok_Semicolon;
            Scan; -- past ;
            P_Pragmas_Misplaced;
         end loop Specification_Loop;

         T_Right_Paren;
         return Specification_List;

      else
         return No_List;
      end if;
   end P_Known_Discriminant_Part_Opt;

   -------------------------------------
   -- 3.7  DIscriminant Specification --
   -------------------------------------

   --  Parsed by P_Known_Discriminant_Part_Opt (3.7)

   -----------------------------
   -- 3.7  Default Expression --
   -----------------------------

   --  Always parsed (simply as an Expression) by the parent construct

   ------------------------------------
   -- 3.7.1  Discriminant Constraint --
   ------------------------------------

   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)

   --------------------------------------------------------
   -- 3.7.1  Index or Discriminant Constraint (also 3.6) --
   --------------------------------------------------------

   --  DISCRIMINANT_CONSTRAINT ::=
   --    (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})

   --  DISCRIMINANT_ASSOCIATION ::=
   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
   --      EXPRESSION

   --  This routine parses either an index or a discriminant constraint. As
   --  is clear from the above grammar, it is often possible to clearly
   --  determine which of the two possibilities we have, but there are
   --  cases (those in which we have a series of expressions of the same
   --  syntactic form as subtype indications), where we cannot tell. Since
   --  this means that in any case the semantic phase has to distinguish
   --  between the two, there is not much point in the parser trying to
   --  distinguish even those cases where the difference is clear. In any
   --  case, if we have a situation like:

   --     (A => 123, 235 .. 500)

   --  it is not clear which of the two items is the wrong one, better to
   --  let the semantic phase give a clear message. Consequently, this
   --  routine in general returns a list of items which can be either
   --  discrete ranges or discriminant associations.

   --  The caller has checked that the initial token is a left paren

   --  Error recovery: can raise Error_Resync

   function P_Index_Or_Discriminant_Constraint return Node_Id is
      Scan_State  : Saved_Scan_State;
      Constr_Node : Node_Id;
      Constr_List : List_Id;
      Expr_Node   : Node_Id;
      Result_Node : Node_Id;

   begin
      Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
      Scan; -- past (
      Constr_List := New_List;
      Set_Constraints (Result_Node, Constr_List);

      --  The two syntactic forms are a little mixed up, so what we are doing
      --  here is looking at the first entry to determine which case we have

      --  A discriminant constraint is a list of discriminant associations,
      --  which have one of the following possible forms:

      --    Expression
      --    Id => Expression
      --    Id | Id | .. | Id => Expression

      --  An index constraint is a list of discrete ranges which have one
      --  of the following possible forms:

      --    Subtype_Mark
      --    Subtype_Mark range Range
      --    Range_Attribute
      --    Simple_Expression .. Simple_Expression

      --  Loop through discriminants in list

      loop
         --  Check cases of Id => Expression or Id | Id => Expression

         if Token = Tok_Identifier then
            Save_Scan_State (Scan_State); -- at Id
            Scan; -- past Id

            if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
               Restore_Scan_State (Scan_State); -- to Id
               Append (P_Discriminant_Association, Constr_List);
               goto Loop_Continue;
            else
               Restore_Scan_State (Scan_State); -- to Id
            end if;
         end if;

         --  Otherwise scan out an expression and see what we have got

         Expr_Node := P_Expression_Or_Range_Attribute;

         if Expr_Form = EF_Range_Attr then
            Append (Expr_Node, Constr_List);

         elsif Token = Tok_Range then
            if Expr_Form /= EF_Simple_Name then
               Error_Msg_SC ("subtype mark required before RANGE");
            end if;

            Append (P_Subtype_Indication (Expr_Node), Constr_List);
            goto Loop_Continue;

         --  Check Simple_Expression .. Simple_Expression case

         elsif Token = Tok_Dot_Dot then
            Check_Simple_Expression (Expr_Node);
            Constr_Node := New_Node (N_Range, Token_Ptr);
            Set_Low_Bound (Constr_Node, Expr_Node);
            Scan; -- past ..
            Expr_Node := P_Expression;
            Check_Simple_Expression (Expr_Node);
            Set_High_Bound (Constr_Node, Expr_Node);
            Append (Constr_Node, Constr_List);
            goto Loop_Continue;

         --  Case of an expression which could be either form

         else
            Append (Expr_Node, Constr_List);
            goto Loop_Continue;
         end if;

         --  Here with a single entry scanned

         <<Loop_Continue>>
            exit when not Comma_Present;

      end loop;

      T_Right_Paren;
      return Result_Node;

   end P_Index_Or_Discriminant_Constraint;

   -------------------------------------
   -- 3.7.1  Discriminant Association --
   -------------------------------------

   --  DISCRIMINANT_ASSOCIATION ::=
   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
   --      EXPRESSION

   --  This routine is used only when the name list is present and the caller
   --  has already checked this (by scanning ahead and repositioning the
   --  scan).

   --  Error_Recovery: cannot raise Error_Resync;

   function P_Discriminant_Association return Node_Id is
      Discr_Node : Node_Id;
      Names_List : List_Id;
      Ident_Sloc : Source_Ptr;

   begin
      Ident_Sloc := Token_Ptr;
      Names_List := New_List;

      loop
         Append (P_Identifier, Names_List);
         exit when Token /= Tok_Vertical_Bar;
         Scan; -- past |
      end loop;

      Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
      Set_Selector_Names (Discr_Node, Names_List);
      TF_Arrow;
      Set_Expression (Discr_Node, P_Expression);
      return Discr_Node;
   end P_Discriminant_Association;

   ---------------------------------
   -- 3.8  Record Type Definition --
   ---------------------------------

   --  RECORD_TYPE_DEFINITION ::=
   --    [[abstract] tagged] [limited] RECORD_DEFINITION

   --  There is no node in the tree for a record type definition. Instead
   --  a record definition node appears, with possible Abstract_Present,
   --  Tagged_Present, and Limited_Present flags set appropriately.

   ----------------------------
   -- 3.8  Record Definition --
   ----------------------------

   --  RECORD_DEFINITION ::=
   --    record
   --      COMPONENT_LIST
   --    end record
   --  | null record

   --  Note: in the case where a record definition node is used to represent
   --  a record type definition, the caller sets the Tagged_Present and
   --  Limited_Present flags in the resulting N_Record_Definition node as
   --  required.

   --  Note that the RECORD token at the start may be missing in certain
   --  error situations, so this function is expected to post the error

   --  Error recovery: can raise Error_Resync

   function P_Record_Definition return Node_Id is
      Rec_Node : Node_Id;

   begin
      Rec_Node := New_Node (N_Record_Definition, Token_Ptr);

      --  Null record case

      if Token = Tok_Null then
         Scan; -- past NULL
         T_Record;
         Set_Null_Present (Rec_Node, True);

      --  Case starting with RECORD keyword. Build scope stack entry. For the
      --  column, we use the first non-blank character on the line, to deal
      --  with situations such as:

      --    type X is record
      --      ...
      --    end record;

      --  which is not official RM indentation, but is not uncommon usage

      else
         Push_Scope_Stack;
         Scope.Table (Scope.Last).Etyp := E_Record;
         Scope.Table (Scope.Last).Ecol := Start_Column;
         Scope.Table (Scope.Last).Sloc := Token_Ptr;
         Scope.Table (Scope.Last).Labl := Error;
         Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);

         T_Record;

         Set_Component_List (Rec_Node, P_Component_List);

         loop
            exit when Check_End;
            Discard_Junk_Node (P_Component_List);
         end loop;
      end if;

      return Rec_Node;
   end P_Record_Definition;

   -------------------------
   -- 3.8  Component List --
   -------------------------

   --  COMPONENT_LIST ::=
   --    COMPONENT_ITEM {COMPONENT_ITEM}
   --  | {COMPONENT_ITEM} VARIANT_PART
   --  | null;

   --  Error recovery: cannot raise Error_Resync

   function P_Component_List return Node_Id is
      Component_List_Node : Node_Id;
      Decls_List          : List_Id;
      Scan_State          : Saved_Scan_State;

   begin
      Component_List_Node := New_Node (N_Component_List, Token_Ptr);
      Decls_List := New_List;

      if Token = Tok_Null then
         Scan; -- past NULL
         TF_Semicolon;
         P_Pragmas_Opt (Decls_List);
         Set_Null_Present (Component_List_Node, True);
         return Component_List_Node;

      else
         P_Pragmas_Opt (Decls_List);

         if Token /= Tok_Case then
            Component_Scan_Loop : loop
               P_Component_Items (Decls_List);
               P_Pragmas_Opt (Decls_List);

               exit Component_Scan_Loop when Token = Tok_End
                 or else Token = Tok_Case
                 or else Token = Tok_When;

               --  We are done if we do not have an identifier. However, if
               --  we have a misspelled reserved identifier that is in a column
               --  to the right of the record definition, we will treat it as
               --  an identifier. It turns out to be too dangerous in practice
               --  to accept such a mis-spelled identifier which does not have
               --  this additional clue that confirms the incorrect spelling.

               if Token /= Tok_Identifier then
                  if Start_Column > Scope.Table (Scope.Last).Ecol
                    and then Is_Reserved_Identifier
                  then
                     Save_Scan_State (Scan_State); -- at reserved id
                     Scan; -- possible reserved id

                     if Token = Tok_Comma or else Token = Tok_Colon then
                        Restore_Scan_State (Scan_State);
                        Scan_Reserved_Identifier (Force_Msg => True);

                     --  Note reserved identifier used as field name after
                     --  all because not followed by colon or comma

                     else
                        Restore_Scan_State (Scan_State);
                        exit Component_Scan_Loop;
                     end if;

                  --  Non-identifier that definitely was not reserved id

                  else
                     exit Component_Scan_Loop;
                  end if;
               end if;
            end loop Component_Scan_Loop;
         end if;

         if Token = Tok_Case then
            Set_Variant_Part (Component_List_Node, P_Variant_Part);

            --  Check for junk after variant part

            if Token = Tok_Identifier then
               Save_Scan_State (Scan_State);
               Scan; -- past identifier

               if Token = Tok_Colon then
                  Restore_Scan_State (Scan_State);
                  Error_Msg_SC ("component may not follow variant part");
                  Discard_Junk_Node (P_Component_List);

               elsif Token = Tok_Case then
                  Restore_Scan_State (Scan_State);
                  Error_Msg_SC ("only one variant part allowed in a record");
                  Discard_Junk_Node (P_Component_List);

               else
                  Restore_Scan_State (Scan_State);
               end if;
            end if;
         end if;
      end if;

      Set_Component_Items (Component_List_Node, Decls_List);
      return Component_List_Node;

   end P_Component_List;

   -------------------------
   -- 3.8  Component Item --
   -------------------------

   --  COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE

   --  COMPONENT_DECLARATION ::=
   --    DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
   --      [:= DEFAULT_EXPRESSION];

   --  COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION

   --  Error recovery: cannot raise Error_Resync, if an error occurs,
   --  the scan is positioned past the following semicolon.

   --  Note: we do not yet allow representation clauses to appear as component
   --  items, do we need to add this capability sometime in the future ???

   procedure P_Component_Items (Decls : List_Id) is
      Decl_Node  : Node_Id;
      Scan_State : Saved_Scan_State;
      Num_Idents : Nat;
      Ident      : Nat;
      Ident_Sloc : Source_Ptr;

      Idents : array (Int range 1 .. 4096) of Entity_Id;
      --  This array holds the list of defining identifiers. The upper bound
      --  of 4096 is intended to be essentially infinite, and we do not even
      --  bother to check for it being exceeded.

   begin
      if Token /= Tok_Identifier then
         Error_Msg_SC ("component declaration expected");
         Resync_Past_Semicolon;
         return;
      end if;

      Ident_Sloc := Token_Ptr;
      Idents (1) := P_Defining_Identifier;
      Num_Idents := 1;

      while Comma_Present loop
         Num_Idents := Num_Idents + 1;
         Idents (Num_Idents) := P_Defining_Identifier;
      end loop;

      T_Colon;

      --  If there are multiple identifiers, we repeatedly scan the
      --  type and initialization expression information by resetting
      --  the scan pointer (so that we get completely separate trees
      --  for each occurrence).

      if Num_Idents > 1 then
         Save_Scan_State (Scan_State);
      end if;

      --  Loop through defining identifiers in list

      Ident := 1;
      Ident_Loop : loop

         --  The following block is present to catch Error_Resync
         --  which causes the parse to be reset past the semicolon

         begin
            Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
            Set_Defining_Identifier (Decl_Node, Idents (Ident));

            if Token = Tok_Constant then
               Error_Msg_SC ("constant components are not permitted");
               Scan;
            end if;

            if Token_Name = Name_Aliased then
               Check_95_Keyword (Tok_Aliased, Tok_Identifier);
            end if;

            if Token = Tok_Aliased then
               Scan; -- past ALIASED
               Set_Aliased_Present (Decl_Node, True);
            end if;

            if Token = Tok_Array then
               Error_Msg_SC ("anonymous arrays not allowed as components");
               raise Error_Resync;
            end if;

            Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
            Set_Expression (Decl_Node, Init_Expr_Opt);

            if Ident > 1 then
               Set_Prev_Ids (Decl_Node, True);
            end if;

            if Ident < Num_Idents then
               Set_More_Ids (Decl_Node, True);
            end if;

            Append (Decl_Node, Decls);

         exception
            when Error_Resync =>
               if Token /= Tok_End then
                  Resync_Past_Semicolon;
               end if;
         end;

         exit Ident_Loop when Ident = Num_Idents;
         Ident := Ident + 1;
         Restore_Scan_State (Scan_State);

      end loop Ident_Loop;

      TF_Semicolon;

   end P_Component_Items;

   --------------------------------
   -- 3.8  Component Declaration --
   --------------------------------

   --  Parsed by P_Component_Items (3.8)

   -------------------------
   -- 3.8.1  Variant Part --
   -------------------------

   --  VARIANT_PART ::=
   --    case discriminant_DIRECT_NAME is
   --      VARIANT
   --      {VARIANT}
   --    end case;

   --  The caller has checked that the initial token is CASE

   --  Error recovery: cannot raise Error_Resync

   function P_Variant_Part return Node_Id is
      Variant_Part_Node : Node_Id;
      Variants_List     : List_Id;
      Case_Node         : Node_Id;
      Case_Sloc         : Source_Ptr;

   begin
      Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
      Push_Scope_Stack;
      Scope.Table (Scope.Last).Etyp := E_Case;
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
      Scope.Table (Scope.Last).Ecol := Start_Column;

      Scan; -- past CASE
      Case_Node := P_Expression;
      Case_Sloc := Token_Ptr;
      Set_Name (Variant_Part_Node, Case_Node);

      if Nkind (Case_Node) /= N_Identifier then
         Set_Name (Variant_Part_Node, Error);
         Error_Msg ("discriminant name expected", Sloc (Case_Node));
      end if;

      TF_Is;
      Variants_List := New_List;
      P_Pragmas_Opt (Variants_List);

      --  Test missing variant

      if Token = Tok_End then
         Error_Msg_BC ("WHEN expected (must have at least one variant)");
      else
         Append (P_Variant, Variants_List);
      end if;

      --  Loop through variants, note that we allow if in place of when,
      --  this error will be detected and handled in P_Variant.

      loop
         P_Pragmas_Opt (Variants_List);

         if Token /= Tok_When
           and then Token /= Tok_If
           and then Token /= Tok_Others
         then
            exit when Check_End;
         end if;

         Append (P_Variant, Variants_List);
      end loop;

      Set_Variants (Variant_Part_Node, Variants_List);
      return Variant_Part_Node;

   end P_Variant_Part;

   --------------------
   -- 3.8.1  Variant --
   --------------------

   --  VARIANT ::=
   --    when DISCRETE_CHOICE_LIST =>
   --      COMPONENT_LIST

   --  Error recovery: cannot raise Error_Resync

   --  The initial token on entry is either WHEN, IF or OTHERS

   function P_Variant return Node_Id is
      Variant_Node : Node_Id;

   begin
      --  Special check to recover nicely from use of IF in place of WHEN

      if Token = Tok_If then
         T_When;
         Scan; -- past IF
      else
         T_When;
      end if;

      Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
      Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
      TF_Arrow;
      Set_Component_List (Variant_Node, P_Component_List);
      return Variant_Node;
   end P_Variant;

   ---------------------------------
   -- 3.8.1  Discrete Choice List --
   ---------------------------------

   --  DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}

   --  DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others

   --  Note: in Ada 83, the expression must be a simple expression

   --  Error recovery: cannot raise Error_Resync

   function P_Discrete_Choice_List return List_Id is
      Choices     : List_Id;
      Expr_Node   : Node_Id;
      Choice_Node : Node_Id;

   begin
      Choices := New_List;

      loop
         if Token = Tok_Others then
            Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
            Scan; -- past OTHERS

         else
            begin
               Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);

               if Token = Tok_Colon
                 and then Nkind (Expr_Node) = N_Identifier
               then
                  Error_Msg_SP ("label not permitted in this context");
                  Scan; -- past colon

               elsif Expr_Form = EF_Range_Attr then
                  Append (Expr_Node, Choices);

               elsif Token = Tok_Dot_Dot then
                  Check_Simple_Expression (Expr_Node);
                  Choice_Node := New_Node (N_Range, Token_Ptr);
                  Set_Low_Bound (Choice_Node, Expr_Node);
                  Scan; -- past ..
                  Expr_Node := P_Expression_No_Right_Paren;
                  Check_Simple_Expression (Expr_Node);
                  Set_High_Bound (Choice_Node, Expr_Node);
                  Append (Choice_Node, Choices);

               elsif Expr_Form = EF_Simple_Name then
                  if Token = Tok_Range then
                     Append (P_Subtype_Indication (Expr_Node), Choices);

                  elsif Token in Token_Class_Consk then
                     Error_Msg_SC
                        ("the only constraint allowed here " &
                         "is a range constraint");
                     Discard_Junk_Node (P_Constraint_Opt);
                     Append (Expr_Node, Choices);

                  else
                     Append (Expr_Node, Choices);
                  end if;

               else
                  Check_Simple_Expression_In_Ada_83 (Expr_Node);
                  Append (Expr_Node, Choices);
               end if;

            exception
               when Error_Resync =>
                  Resync_Choice;
                  return Error_List;
            end;
         end if;

         if Token = Tok_Comma then
            Error_Msg_SC (""","" should be ""'|""");
         else
            exit when Token /= Tok_Vertical_Bar;
         end if;

         Scan; -- past | or comma
      end loop;

      return Choices;
   end P_Discrete_Choice_List;

   ----------------------------
   -- 3.8.1  Discrete Choice --
   ----------------------------

   --  Parsed by P_Discrete_Choice_List (3.8.1)

   ----------------------------------
   -- 3.9.1  Record Extension Part --
   ----------------------------------

   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION

   --  Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)

   ----------------------------------
   -- 3.10  Access Type Definition --
   ----------------------------------

   --  ACCESS_TYPE_DEFINITION ::=
   --    ACCESS_TO_OBJECT_DEFINITION
   --  | ACCESS_TO_SUBPROGRAM_DEFINITION

   --  ACCESS_TO_OBJECT_DEFINITION ::=
   --    access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION

   --  GENERAL_ACCESS_MODIFIER ::= all | constant

   --  ACCESS_TO_SUBPROGRAM_DEFINITION
   --    access [protected] procedure PARAMETER_PROFILE
   --  | access [protected] function PARAMETER_AND_RESULT_PROFILE

   --  PARAMETER_PROFILE ::= [FORMAL_PART]

   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK

   --  The caller has checked that the initial token is ACCESS

   --  Error recovery: can raise Error_Resync

   function P_Access_Type_Definition return Node_Id is
      Prot_Flag     : Boolean;
      Access_Loc    : Source_Ptr;
      Type_Def_Node : Node_Id;

      procedure Check_Junk_Subprogram_Name;
      --  Used in access to subprogram definition cases to check for an
      --  identifier or operator symbol that does not belong.

      procedure Check_Junk_Subprogram_Name is
         Saved_State : Saved_Scan_State;

      begin
         if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
            Save_Scan_State (Saved_State);
            Scan; -- past possible junk subprogram name

            if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
               Error_Msg_SP ("unexpected subprogram name ignored");
               return;

            else
               Restore_Scan_State (Saved_State);
            end if;
         end if;
      end Check_Junk_Subprogram_Name;

   --  Start of processing for P_Access_Type_Definition

   begin
      Access_Loc := Token_Ptr;
      Scan; -- past ACCESS

      if Token_Name = Name_Protected then
         Check_95_Keyword (Tok_Protected, Tok_Procedure);
         Check_95_Keyword (Tok_Protected, Tok_Function);
      end if;

      Prot_Flag := (Token = Tok_Protected);

      if Prot_Flag then
         Scan; -- past PROTECTED
         if Token /= Tok_Procedure and then Token /= Tok_Function then
            Error_Msg_SC ("FUNCTION or PROCEDURE expected");
         end if;
      end if;

      if Token = Tok_Procedure then
         if Ada_83 then
            Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
         end if;

         Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
         Scan; -- past PROCEDURE
         Check_Junk_Subprogram_Name;
         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
         Set_Protected_Present (Type_Def_Node, Prot_Flag);

      elsif Token = Tok_Function then
         if Ada_83 then
            Error_Msg_SC ("(Ada 83) access to function not allowed!");
         end if;

         Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
         Scan; -- past FUNCTION
         Check_Junk_Subprogram_Name;
         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
         Set_Protected_Present (Type_Def_Node, Prot_Flag);
         TF_Return;
         Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
         No_Constraint;

      else
         Type_Def_Node :=
           New_Node (N_Access_To_Object_Definition, Access_Loc);

         if Token = Tok_All or else Token = Tok_Constant then
            if Ada_83 then
               Error_Msg_SC ("(Ada 83) access modifier not allowed!");
            end if;

            if Token = Tok_All then
               Set_All_Present (Type_Def_Node, True);

            else
               Set_Constant_Present (Type_Def_Node, True);
            end if;

            Scan; -- past ALL or CONSTANT
         end if;

         Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication);
      end if;

      return Type_Def_Node;
   end P_Access_Type_Definition;

   ---------------------------------------
   -- 3.10  Access To Object Definition --
   ---------------------------------------

   --  Parsed by P_Access_Type_Definition (3.10)

   -----------------------------------
   -- 3.10  General Access Modifier --
   -----------------------------------

   --  Parsed by P_Access_Type_Definition (3.10)

   -------------------------------------------
   -- 3.10  Access To Subprogram Definition --
   -------------------------------------------

   --  Parsed by P_Access_Type_Definition (3.10)

   -----------------------------
   -- 3.10  Access Definition --
   -----------------------------

   --  ACCESS_DEFINITION ::= access SUBTYPE_MARK

   --  The caller has checked that the initial token is ACCESS

   --  Error recovery: cannot raise Error_Resync

   function P_Access_Definition return Node_Id is
      Def_Node : Node_Id;

   begin
      Def_Node := New_Node (N_Access_Definition, Token_Ptr);
      Scan; -- past ACCESS
      Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
      No_Constraint;
      return Def_Node;
   end P_Access_Definition;

   -----------------------------------------
   -- 3.10.1  Incomplete Type Declaration --
   -----------------------------------------

   --  Parsed by P_Type_Declaration (3.2.1)

   ----------------------------
   -- 3.11  Declarative Part --
   ----------------------------

   --  DECLARATIVE_PART ::= {DECLARATIVE_ITEM}

   --  Error recovery: cannot raise Error_Resync (because P_Declarative_Items
   --  handles errors, and returns cleanly after an error has occurred)

   function P_Declarative_Part return List_Id is
      Decls : List_Id;
      Done  : Boolean;

   begin
      --  Indicate no bad declarations detected yet. This will be reset by
      --  P_Declarative_Items if a bad declaration is discovered.

      Missing_Begin_Msg := No_Error_Msg;

      --  Get rid of active SIS entry from outer scope. This means we will
      --  miss some nested cases, but it doesn't seem worth the effort. See
      --  discussion in Par for further details

      SIS_Entry_Active := False;
      Decls := New_List;

      --  Loop to scan out the declarations

      loop
         P_Declarative_Items (Decls, Done, In_Spec => False);
         exit when Done;
      end loop;

      --  Get rid of active SIS entry which is left set only if we scanned a
      --  procedure declaration and have not found the body. We could give
      --  an error message, but that really would be usurping the role of
      --  semantic analysis (this really is a missing body case).

      SIS_Entry_Active := False;
      return Decls;
   end P_Declarative_Part;

   ----------------------------
   -- 3.11  Declarative Item --
   ----------------------------

   --  DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY

   --  Can return Error if a junk declaration is found, or Empty if no
   --  declaration is found (i.e. a token ending declarations, such as
   --  BEGIN or END is encountered).

   --  Error recovery: cannot raise Error_Resync. If an error resync occurs,
   --  then the scan is set past the next semicolon and Error is returned.

   procedure P_Declarative_Items
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean)
   is
      Scan_State : Saved_Scan_State;

   begin
      if Style_Check then Style.Check_Indentation; end if;

      case Token is

         when Tok_Function =>
            Check_Bad_Layout;
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
            Done := False;

         when Tok_For =>
            Check_Bad_Layout;

            --  Check for loop (premature statement)

            Save_Scan_State (Scan_State);
            Scan; -- past FOR

            if Token = Tok_Identifier then
               Scan; -- past identifier

               if Token = Tok_In then
                  Restore_Scan_State (Scan_State);
                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
                  return;
               end if;
            end if;

            --  Not a loop, so must be rep clause

            Restore_Scan_State (Scan_State);
            Append (P_Representation_Clause, Decls);
            Done := False;

         when Tok_Generic =>
            Check_Bad_Layout;
            Append (P_Generic, Decls);
            Done := False;

         when Tok_Identifier =>
            Check_Bad_Layout;
            P_Identifier_Declarations (Decls, Done, In_Spec);

         when Tok_Package =>
            Check_Bad_Layout;
            Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
            Done := False;

         when Tok_Pragma =>
            Append (P_Pragma, Decls);
            Done := False;

         when Tok_Procedure =>
            Check_Bad_Layout;
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
            Done := False;

         when Tok_Protected =>
            Check_Bad_Layout;
            Scan; -- past PROTECTED
            Append (P_Protected, Decls);
            Done := False;

         when Tok_Subtype =>
            Check_Bad_Layout;
            Append (P_Subtype_Declaration, Decls);
            Done := False;

         when Tok_Task =>
            Check_Bad_Layout;
            Scan; -- past TASK
            Append (P_Task, Decls);
            Done := False;

         when Tok_Type =>
            Check_Bad_Layout;
            Append (P_Type_Declaration, Decls);
            Done := False;

         when Tok_Use =>
            Check_Bad_Layout;
            Append (P_Use_Clause, Decls);
            Done := False;

         when Tok_With =>
            Check_Bad_Layout;
            Error_Msg_SC ("WITH can only appear in context clause");
            raise Error_Resync;

         --  BEGIN terminates the scan of a sequence of declarations unless
         --  there is a missing subprogram body, see section on handling
         --  semicolon in place of IS. We only treat the begin as satisfying
         --  the subprogram declaration if it falls in the expected column
         --  or to its right.

         when Tok_Begin =>
            if SIS_Entry_Active and then Start_Column >= SIS_Ecol then

               --  Here we have the case where a BEGIN is encountered during
               --  declarations in a declarative part, or at the outer level,
               --  and there is a subprogram declaration outstanding for which
               --  no body has been supplied. This is the case where we assume
               --  that the semicolon in the subprogram declaration should
               --  really have been is. The active SIS entry describes the
               --  subprogram declaration. On return the declaration has been
               --  modified to become a body.

               declare
                  Specification_Node : Node_Id;
                  Decl_Node          : Node_Id;
                  Body_Node          : Node_Id;

               begin
                  --  First issue the error message. If we had a missing
                  --  semicolon in the declaration, then change the message
                  --  to <missing "is">

                  if SIS_Missing_Semicolon_Message /= No_Error_Msg then
                     Change_Error_Text     -- Replace: "missing "";"" "
                       (SIS_Missing_Semicolon_Message, "missing ""is""");

                  --  Otherwise we saved the semicolon position, so complain

                  else
                     Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
                  end if;

                  --  The next job is to fix up any declarations that occurred
                  --  between the procedure header and the BEGIN. These got
                  --  chained to the outer declarative region (immediately
                  --  after the procedure declaration) and they should be
                  --  chained to the subprogram itself, which is a body
                  --  rather than a spec.

                  Specification_Node := Specification (SIS_Declaration_Node);
                  Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
                  Body_Node := SIS_Declaration_Node;
                  Set_Specification (Body_Node, Specification_Node);
                  Set_Declarations (Body_Node, New_List);

                  loop
                     Decl_Node := Remove_Next (Body_Node);
                     exit when Decl_Node = Empty;
                     Append (Decl_Node, Declarations (Body_Node));
                  end loop;

                  --  Now make the scope table entry for the Begin-End and
                  --  scan it out

                  Push_Scope_Stack;
                  Scope.Table (Scope.Last).Sloc := SIS_Sloc;
                  Scope.Table (Scope.Last).Etyp := E_Name;
                  Scope.Table (Scope.Last).Ecol := SIS_Ecol;
                  Scope.Table (Scope.Last).Labl := SIS_Labl;
                  Scope.Table (Scope.Last).Lreq := False;
                  SIS_Entry_Active := False;
                  Scan; -- past BEGIN
                  Set_Handled_Statement_Sequence (Body_Node,
                    P_Handled_Sequence_Of_Statements);
                  End_Statements (Handled_Statement_Sequence (Body_Node));
               end;

               Done := False;

            else
               Done := True;
            end if;

            --  Normally an END terminates the scan for basic declarative
            --  items. The one exception is END RECORD, which is probably
            --  left over from some other junk.

            when Tok_End =>
               Save_Scan_State (Scan_State); -- at END
               Scan; -- past END

               if Token = Tok_Record then
                  Error_Msg_SP ("no RECORD for this `end record`!");
                  Scan; -- past RECORD
                  TF_Semicolon;

               else
                  Restore_Scan_State (Scan_State); -- to END
                  Done := True;
               end if;

         --  The following tokens which can only be the start of a statement
         --  are considered to end a declarative part (i.e. we have a missing
         --  BEGIN situation). We are fairly conservative in making this
         --  judgment, because it is a real mess to go into statement mode
         --  prematurely in response to a junk declaration.

         when Tok_Abort     |
              Tok_Accept    |
              Tok_Declare   |
              Tok_Delay     |
              Tok_Exit      |
              Tok_Goto      |
              Tok_If        |
              Tok_Loop      |
              Tok_Null      |
              Tok_Requeue   |
              Tok_Select    |
              Tok_While     =>

            --  But before we decide that it's a statement, let's check for
            --  a reserved word misused as an identifier.

            if Is_Reserved_Identifier then
               Save_Scan_State (Scan_State);
               Scan; -- past the token

               --  If reserved identifier not followed by colon or comma, then
               --  this is most likely an assignment statement to the bad id.

               if Token /= Tok_Colon and then Token /= Tok_Comma then
                  Restore_Scan_State (Scan_State);
                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
                  return;

               --  Otherwise we have a declaration of the bad id

               else
                  Restore_Scan_State (Scan_State);
                  Scan_Reserved_Identifier (Force_Msg => True);
                  P_Identifier_Declarations (Decls, Done, In_Spec);
               end if;

            --  If not reserved identifier, then it's definitely a statement

            else
               Statement_When_Declaration_Expected (Decls, Done, In_Spec);
               return;
            end if;

         --  The token RETURN may well also signal a missing BEGIN situation,
         --  however, we never let it end the declarative part, because it may
         --  also be part of a half-baked function declaration.

         when Tok_Return =>
            Error_Msg_SC ("misplaced RETURN statement");
            raise Error_Resync;

         --  PRIVATE definitely terminates the declarations in a spec,
         --  and is an error in a body.

         when Tok_Private =>
            if In_Spec then
               Done := True;
            else
               Error_Msg_SC ("PRIVATE not allowed in body");
               Scan; -- past PRIVATE
            end if;

         --  An end of file definitely terminates the declarations!

         when Tok_EOF =>
            Done := True;

         --  The remaining tokens do not end the scan, but cannot start a
         --  valid declaration, so we signal an error and resynchronize.
         --  But first check for misuse of a reserved identifier.

         when others =>

            --  Here we check for a reserved identifier

            if Is_Reserved_Identifier then
               Save_Scan_State (Scan_State);
               Scan; -- past the token

               if Token /= Tok_Colon and then Token /= Tok_Comma then
                  Restore_Scan_State (Scan_State);
                  Set_Declaration_Expected;
                  raise Error_Resync;
               else
                  Restore_Scan_State (Scan_State);
                  Scan_Reserved_Identifier (Force_Msg => True);
                  Check_Bad_Layout;
                  P_Identifier_Declarations (Decls, Done, In_Spec);
               end if;

            else
               Set_Declaration_Expected;
               raise Error_Resync;
            end if;
      end case;

   --  To resynchronize after an error, we scan to the next semicolon and
   --  return with Done = False, indicating that there may still be more
   --  valid declarations to come.

   exception
      when Error_Resync =>
         Resync_Past_Semicolon;
         Done := False;

   end P_Declarative_Items;

   ----------------------------------
   -- 3.11  Basic Declarative Item --
   ----------------------------------

   --  BASIC_DECLARATIVE_ITEM ::=
   --    BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE

   --  Scan zero or more basic declarative items

   --  Error recovery: cannot raise Error_Resync. If an error is detected, then
   --  the scan pointer is repositioned past the next semicolon, and the scan
   --  for declarative items continues.

   function P_Basic_Declarative_Items return List_Id is
      Decl  : Node_Id;
      Decls : List_Id;
      Kind  : Node_Kind;
      Done  : Boolean;

   begin
      --  Get rid of active SIS entry from outer scope. This means we will
      --  miss some nested cases, but it doesn't seem worth the effort. See
      --  discussion in Par for further details

      SIS_Entry_Active := False;

      --  Loop to scan out declarations

      Decls := New_List;

      loop
         P_Declarative_Items (Decls, Done, In_Spec => True);
         exit when Done;
      end loop;

      --  Get rid of active SIS entry. This is set only if we have scanned a
      --  procedure declaration and have not found the body. We could give
      --  an error message, but that really would be usurping the role of
      --  semantic analysis (this really is a case of a missing body).

      SIS_Entry_Active := False;

      --  Test for assorted illegal declarations not diagnosed elsewhere.

      Decl := First (Decls);

      while Present (Decl) loop
         Kind := Nkind (Decl);

         --  Test for body scanned, not acceptable as basic decl item

         if Kind = N_Subprogram_Body or else
            Kind = N_Package_Body or else
            Kind = N_Task_Body or else
            Kind = N_Protected_Body
         then
            Error_Msg
              ("proper body not allowed in package spec", Sloc (Decl));

         --  Test for body stub scanned, not acceptable as basic decl item

         elsif Kind in N_Body_Stub then
            Error_Msg
              ("body stub not allowed in package spec", Sloc (Decl));

         elsif Kind = N_Assignment_Statement then
            Error_Msg
              ("assignment statement not allowed in package spec",
                 Sloc (Decl));
         end if;

         Next (Decl);
      end loop;

      return Decls;
   end P_Basic_Declarative_Items;

   ----------------
   -- 3.11  Body --
   ----------------

   --  For proper body, see below
   --  For body stub, see 10.1.3

   -----------------------
   -- 3.11  Proper Body --
   -----------------------

   --  Subprogram body is parsed by P_Subprogram (6.1)
   --  Package body is parsed by P_Package (7.1)
   --  Task body is parsed by P_Task (9.1)
   --  Protected body is parsed by P_Protected (9.4)

   ------------------------------
   -- Set_Declaration_Expected --
   ------------------------------

   procedure Set_Declaration_Expected is
   begin
      Error_Msg_SC ("declaration expected");

      if Missing_Begin_Msg = No_Error_Msg then
         Missing_Begin_Msg := Get_Msg_Id;
      end if;
   end Set_Declaration_Expected;

   ----------------------
   -- Skip_Declaration --
   ----------------------

   procedure Skip_Declaration (S : List_Id) is
      Dummy_Done : Boolean;

   begin
      P_Declarative_Items (S, Dummy_Done, False);
   end Skip_Declaration;

   -----------------------------------------
   -- Statement_When_Declaration_Expected --
   -----------------------------------------

   procedure Statement_When_Declaration_Expected
     (Decls   : List_Id;
      Done    : out Boolean;
      In_Spec : Boolean)
   is
   begin
      --  Case of second occurrence of statement in one declaration sequence

      if Missing_Begin_Msg /= No_Error_Msg then

         --  In the procedure spec case, just ignore it, we only give one
         --  message for the first occurrence, since otherwise we may get
         --  horrible cascading if BODY was missing in the header line.

         if In_Spec then
            null;

         --  In the declarative part case, take a second statement as a sure
         --  sign that we really have a missing BEGIN, and end the declarative
         --  part now. Note that the caller will fix up the first message to
         --  say "missing BEGIN" so that's how the error will be signalled.

         else
            Done := True;
            return;
         end if;

      --  Case of first occurrence of unexpected statement

      else
         --  If we are in a package spec, then give message of statement
         --  not allowed in package spec. This message never gets changed.

         if In_Spec then
            Error_Msg_SC ("statement not allowed in package spec");

         --  If in declarative part, then we give the message complaining
         --  about finding a statement when a declaration is expected. This
         --  gets changed to a complaint about a missing BEGIN if we later
         --  find that no BEGIN is present.

         else
            Error_Msg_SC ("statement not allowed in declarative part");
         end if;

         --  Capture message Id. This is used for two purposes, first to
         --  stop multiple messages, see test above, and second, to allow
         --  the replacement of the message in the declarative part case.

         Missing_Begin_Msg := Get_Msg_Id;
      end if;

      --  In all cases except the case in which we decided to terminate the
      --  declaration sequence on a second error, we scan out the statement
      --  and append it to the list of declarations (note that the semantics
      --  can handle statements in a declaration list so if we proceed to
      --  call the semantic phase, all will be (reasonably) well!

      Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));

      --  Done is set to False, since we want to continue the scan of
      --  declarations, hoping that this statement was a temporary glitch.
      --  If we indeed are now in the statement part (i.e. this was a missing
      --  BEGIN, then it's not terrible, we will simply keep calling this
      --  procedure to process the statements one by one, and then finally
      --  hit the missing BEGIN, which will clean up the error message.

      Done := False;

   end Statement_When_Declaration_Expected;

end Ch3;