-----------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              P A R . C H 4                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2018, 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- 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 Stringt; use Stringt;

separate (Par)
package body Ch4 is

   --  Attributes that cannot have arguments

   Is_Parameterless_Attribute : constant Attribute_Class_Array :=
     (Attribute_Base         => True,
      Attribute_Body_Version => True,
      Attribute_Class        => True,
      Attribute_External_Tag => True,
      Attribute_Img          => True,
      Attribute_Loop_Entry   => True,
      Attribute_Old          => True,
      Attribute_Result       => True,
      Attribute_Stub_Type    => True,
      Attribute_Version      => True,
      Attribute_Type_Key     => True,
      others                 => False);
   --  This map contains True for parameterless attributes that return a string
   --  or a type. For those attributes, a left parenthesis after the attribute
   --  should not be analyzed as the beginning of a parameters list because it
   --  may denote a slice operation (X'Img (1 .. 2)) or a type conversion
   --  (X'Class (Y)). The Ada 2012 attribute 'Old is in this category.

   --  Note: Loop_Entry is in this list because, although it can take an
   --  optional argument (the loop name), we can't distinguish that at parse
   --  time from the case where no loop name is given and a legitimate index
   --  expression is present. So we parse the argument as an indexed component
   --  and the semantic analysis sorts out this syntactic ambiguity based on
   --  the type and form of the expression.

   --  Note that this map designates the minimum set of attributes where a
   --  construct in parentheses that is not an argument can appear right
   --  after the attribute. For attributes like 'Size, we do not put them
   --  in the map. If someone writes X'Size (3), that's illegal in any case,
   --  but we get a better error message by parsing the (3) as an illegal
   --  argument to the attribute, rather than some meaningless junk that
   --  follows the attribute.

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

   function P_Aggregate_Or_Paren_Expr                 return Node_Id;
   function P_Allocator                               return Node_Id;
   function P_Case_Expression_Alternative             return Node_Id;
   function P_Iterated_Component_Assoc_Or_Reduction   return Node_Id;
   function P_Reduction_Expression (Lparen : Boolean) return Node_Id;
   function P_Record_Or_Array_Component_Association   return Node_Id;
   function P_Factor                                  return Node_Id;
   function P_Primary                                 return Node_Id;
   function P_Relation                                return Node_Id;
   function P_Term                                    return Node_Id;

   function P_Binary_Adding_Operator                  return Node_Kind;
   function P_Logical_Operator                        return Node_Kind;
   function P_Multiplying_Operator                    return Node_Kind;
   function P_Relational_Operator                     return Node_Kind;
   function P_Unary_Adding_Operator                   return Node_Kind;

   procedure Bad_Range_Attribute (Loc : Source_Ptr);
   --  Called to place complaint about bad range attribute at the given
   --  source location. Terminates by raising Error_Resync.

   procedure Check_Bad_Exp;
   --  Called after scanning a**b, posts error if ** detected

   procedure P_Membership_Test (N : Node_Id);
   --  N is the node for a N_In or N_Not_In node whose right operand has not
   --  yet been processed. It is called just after scanning out the IN keyword.
   --  On return, either Right_Opnd or Alternatives is set, as appropriate.

   function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
   --  Scan a range attribute reference. The caller has scanned out the
   --  prefix. The current token is known to be an apostrophe and the
   --  following token is known to be RANGE.

   function P_Unparen_Cond_Case_Quant_Expression return Node_Id;
   --  This function is called with Token pointing to IF, CASE, or FOR, in a
   --  context that allows a case, conditional, or quantified expression if
   --  it is surrounded by parentheses. If not surrounded by parentheses, the
   --  expression is still returned, but an error message is issued.

   -------------------------
   -- Bad_Range_Attribute --
   -------------------------

   procedure Bad_Range_Attribute (Loc : Source_Ptr) is
   begin
      Error_Msg ("range attribute cannot be used in expression!", Loc);
      Resync_Expression;
   end Bad_Range_Attribute;

   -------------------
   -- Check_Bad_Exp --
   -------------------

   procedure Check_Bad_Exp is
   begin
      if Token = Tok_Double_Asterisk then
         Error_Msg_SC ("parenthesization required for '*'*");
         Scan; -- past **
         Discard_Junk_Node (P_Primary);
         Check_Bad_Exp;
      end if;
   end Check_Bad_Exp;

   --------------------------
   -- 4.1  Name (also 6.4) --
   --------------------------

   --  NAME ::=
   --    DIRECT_NAME        | EXPLICIT_DEREFERENCE
   --  | INDEXED_COMPONENT  | SLICE
   --  | SELECTED_COMPONENT | ATTRIBUTE
   --  | TYPE_CONVERSION    | FUNCTION_CALL
   --  | CHARACTER_LITERAL  | TARGET_NAME

   --  DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL

   --  PREFIX ::= NAME | IMPLICIT_DEREFERENCE

   --  EXPLICIT_DEREFERENCE ::= NAME . all

   --  IMPLICIT_DEREFERENCE ::= NAME

   --  INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})

   --  SLICE ::= PREFIX (DISCRETE_RANGE)

   --  SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME

   --  SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL

   --  ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR

   --  ATTRIBUTE_DESIGNATOR ::=
   --    IDENTIFIER [(static_EXPRESSION)]
   --  | access | delta | digits

   --  FUNCTION_CALL ::=
   --    function_NAME
   --  | function_PREFIX ACTUAL_PARAMETER_PART

   --  ACTUAL_PARAMETER_PART ::=
   --    (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})

   --  PARAMETER_ASSOCIATION ::=
   --    [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER

   --  EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME

   --  TARGET_NAME ::= @   (AI12-0125-3: abbreviation for LHS)

   --  Note: syntactically a procedure call looks just like a function call,
   --  so this routine is in practice used to scan out procedure calls as well.

   --  On return, Expr_Form is set to either EF_Name or EF_Simple_Name

   --  Error recovery: can raise Error_Resync

   --  Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
   --  followed by either a left paren (qualified expression case), or by
   --  range (range attribute case). All other uses of apostrophe (i.e. all
   --  other attributes) are handled in this routine.

   --  Error recovery: can raise Error_Resync

   function P_Name return Node_Id is
      Scan_State  : Saved_Scan_State;
      Name_Node   : Node_Id;
      Prefix_Node : Node_Id;
      Ident_Node  : Node_Id;
      Expr_Node   : Node_Id;
      Range_Node  : Node_Id;
      Arg_Node    : Node_Id;

      Arg_List  : List_Id := No_List; -- kill junk warning
      Attr_Name : Name_Id := No_Name; -- kill junk warning

   begin
      --  Case of not a name

      if Token not in Token_Class_Name then

         --  If it looks like start of expression, complain and scan expression

         if Token in Token_Class_Literal
           or else Token = Tok_Left_Paren
         then
            Error_Msg_SC ("name expected");
            return P_Expression;

         --  Otherwise some other junk, not much we can do

         else
            Error_Msg_AP ("name expected");
            raise Error_Resync;
         end if;
      end if;

      --  Loop through designators in qualified name
      --  AI12-0125 : target_name

      if Token = Tok_At_Sign then
         Scan_Reserved_Identifier (Force_Msg => False);

         if Present (Current_Assign_Node) then
            Set_Has_Target_Names (Current_Assign_Node);
         end if;
      end if;

      Name_Node := Token_Node;

      loop
         Scan; -- past designator
         exit when Token /= Tok_Dot;
         Save_Scan_State (Scan_State); -- at dot
         Scan; -- past dot

         --  If we do not have another designator after the dot, then join
         --  the normal circuit to handle a dot extension (may be .all or
         --  character literal case). Otherwise loop back to scan the next
         --  designator.

         if Token not in Token_Class_Desig then
            goto Scan_Name_Extension_Dot;
         else
            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Selector_Name (Name_Node, Token_Node);
         end if;
      end loop;

      --  We have now scanned out a qualified designator. If the last token is
      --  an operator symbol, then we certainly do not have the Snam case, so
      --  we can just use the normal name extension check circuit

      if Prev_Token = Tok_Operator_Symbol then
         goto Scan_Name_Extension;
      end if;

      --  We have scanned out a qualified simple name, check for name extension
      --  Note that we know there is no dot here at this stage, so the only
      --  possible cases of name extension are apostrophe and left paren.

      if Token = Tok_Apostrophe then
         Save_Scan_State (Scan_State); -- at apostrophe
         Scan; -- past apostrophe

         --  Qualified expression in Ada 2012 mode (treated as a name)

         if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
            goto Scan_Name_Extension_Apostrophe;

         --  If left paren not in Ada 2012, then it is not part of the name,
         --  since qualified expressions are not names in prior versions of
         --  Ada, so return with Token backed up to point to the apostrophe.
         --  The treatment for the range attribute is similar (we do not
         --  consider x'range to be a name in this grammar).

         elsif Token = Tok_Left_Paren or else Token = Tok_Range then
            Restore_Scan_State (Scan_State); -- to apostrophe
            Expr_Form := EF_Simple_Name;
            return Name_Node;

         --  Otherwise we have the case of a name extended by an attribute

         else
            goto Scan_Name_Extension_Apostrophe;
         end if;

      --  Check case of qualified simple name extended by a left parenthesis

      elsif Token = Tok_Left_Paren then
         Scan; -- past left paren
         goto Scan_Name_Extension_Left_Paren;

      --  Otherwise the qualified simple name is not extended, so return

      else
         Expr_Form := EF_Simple_Name;
         return Name_Node;
      end if;

      --  Loop scanning past name extensions. A label is used for control
      --  transfer for this loop for ease of interfacing with the finite state
      --  machine in the parenthesis scanning circuit, and also to allow for
      --  passing in control to the appropriate point from the above code.

      <<Scan_Name_Extension>>

         --  Character literal used as name cannot be extended. Also this
         --  cannot be a call, since the name for a call must be a designator.
         --  Return in these cases, or if there is no name extension

         if Token not in Token_Class_Namext
           or else Prev_Token = Tok_Char_Literal
         then
            Expr_Form := EF_Name;
            return Name_Node;
         end if;

      --  Merge here when we know there is a name extension

      <<Scan_Name_Extension_OK>>

         if Token = Tok_Left_Paren then
            Scan; -- past left paren
            goto Scan_Name_Extension_Left_Paren;

         elsif Token = Tok_Apostrophe then
            Save_Scan_State (Scan_State); -- at apostrophe
            Scan; -- past apostrophe
            goto Scan_Name_Extension_Apostrophe;

         else -- Token = Tok_Dot
            Save_Scan_State (Scan_State); -- at dot
            Scan; -- past dot
            goto Scan_Name_Extension_Dot;
         end if;

      --  Case of name extended by dot (selection), dot is already skipped
      --  and the scan state at the point of the dot is saved in Scan_State.

      <<Scan_Name_Extension_Dot>>

         --  Explicit dereference case

         if Token = Tok_All then
            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
            Set_Prefix (Name_Node, Prefix_Node);
            Scan; -- past ALL
            goto Scan_Name_Extension;

         --  Selected component case

         elsif Token in Token_Class_Name then
            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Selector_Name (Name_Node, Token_Node);
            Scan; -- past selector
            goto Scan_Name_Extension;

         --  Reserved identifier as selector

         elsif Is_Reserved_Identifier then
            Scan_Reserved_Identifier (Force_Msg => False);
            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Selector_Name (Name_Node, Token_Node);
            Scan; -- past identifier used as selector
            goto Scan_Name_Extension;

         --  If dot is at end of line and followed by nothing legal,
         --  then assume end of name and quit (dot will be taken as
         --  an incorrect form of some other punctuation by our caller).

         elsif Token_Is_At_Start_Of_Line then
            Restore_Scan_State (Scan_State);
            return Name_Node;

         --  Here if nothing legal after the dot

         else
            Error_Msg_AP ("selector expected");
            raise Error_Resync;
         end if;

      --  Here for an apostrophe as name extension. The scan position at the
      --  apostrophe has already been saved, and the apostrophe scanned out.

      <<Scan_Name_Extension_Apostrophe>>

         Scan_Apostrophe : declare
            function Apostrophe_Should_Be_Semicolon return Boolean;
            --  Checks for case where apostrophe should probably be
            --  a semicolon, and if so, gives appropriate message,
            --  resets the scan pointer to the apostrophe, changes
            --  the current token to Tok_Semicolon, and returns True.
            --  Otherwise returns False.

            ------------------------------------
            -- Apostrophe_Should_Be_Semicolon --
            ------------------------------------

            function Apostrophe_Should_Be_Semicolon return Boolean is
            begin
               if Token_Is_At_Start_Of_Line then
                  Restore_Scan_State (Scan_State); -- to apostrophe
                  Error_Msg_SC ("|""''"" should be "";""");
                  Token := Tok_Semicolon;
                  return True;
               else
                  return False;
               end if;
            end Apostrophe_Should_Be_Semicolon;

         --  Start of processing for Scan_Apostrophe

         begin
            --  Check for qualified expression case in Ada 2012 mode

            if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
               Name_Node := P_Qualified_Expression (Name_Node);
               goto Scan_Name_Extension;

            --  If range attribute after apostrophe, then return with Token
            --  pointing to the apostrophe. Note that in this case the prefix
            --  need not be a simple name (cases like A.all'range). Similarly
            --  if there is a left paren after the apostrophe, then we also
            --  return with Token pointing to the apostrophe (this is the
            --  aggregate case, or some error case).

            elsif Token = Tok_Range or else Token = Tok_Left_Paren then
               Restore_Scan_State (Scan_State); -- to apostrophe
               Expr_Form := EF_Name;
               return Name_Node;

            --  Here for cases where attribute designator is an identifier

            elsif Token = Tok_Identifier then
               Attr_Name := Token_Name;

               if not Is_Attribute_Name (Attr_Name) then
                  if Apostrophe_Should_Be_Semicolon then
                     Expr_Form := EF_Name;
                     return Name_Node;

                  --  Here for a bad attribute name

                  else
                     Signal_Bad_Attribute;
                     Scan; -- past bad identifier

                     if Token = Tok_Left_Paren then
                        Scan; -- past left paren

                        loop
                           Discard_Junk_Node (P_Expression_If_OK);
                           exit when not Comma_Present;
                        end loop;

                        T_Right_Paren;
                     end if;

                     return Error;
                  end if;
               end if;

               if Style_Check then
                  Style.Check_Attribute_Name (False);
               end if;

            --  Here for case of attribute designator is not an identifier

            else
               if Token = Tok_Delta then
                  Attr_Name := Name_Delta;

               elsif Token = Tok_Digits then
                  Attr_Name := Name_Digits;

               elsif Token = Tok_Access then
                  Attr_Name := Name_Access;

               elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
                  Attr_Name := Name_Mod;

               elsif Apostrophe_Should_Be_Semicolon then
                  Expr_Form := EF_Name;
                  return Name_Node;

               else
                  Error_Msg_AP ("attribute designator expected");
                  raise Error_Resync;
               end if;

               if Style_Check then
                  Style.Check_Attribute_Name (True);
               end if;
            end if;

            --  We come here with an OK attribute scanned, and corresponding
            --  Attribute identifier node stored in Ident_Node.

            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
            Scan; -- past attribute designator
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Attribute_Name (Name_Node, Attr_Name);

            --  Scan attribute arguments/designator. We skip this if we know
            --  that the attribute cannot have an argument (see documentation
            --  of Is_Parameterless_Attribute for further details).

            if Token = Tok_Left_Paren
              and then not
                Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
            then
               --  Attribute Update contains an array or record association
               --  list which provides new values for various components or
               --  elements. The list is parsed as an aggregate, and we get
               --  better error handling by knowing that in the parser.

               if Attr_Name = Name_Update then
                  Set_Expressions (Name_Node, New_List);
                  Append (P_Aggregate, Expressions (Name_Node));

               --  All other cases of parsing attribute arguments

               else
                  Set_Expressions (Name_Node, New_List);
                  Scan; -- past left paren

                  loop
                     declare
                        Expr : constant Node_Id := P_Expression_If_OK;
                        Rnam : Node_Id;

                     begin
                        --  Case of => for named notation

                        if Token = Tok_Arrow then

                           --  Named notation allowed only for the special
                           --  case of System'Restriction_Set (No_Dependence =>
                           --  unit_NAME), in which case construct a parameter
                           --  assocation node and append to the arguments.

                           if Attr_Name = Name_Restriction_Set
                             and then Nkind (Expr) = N_Identifier
                             and then Chars (Expr) = Name_No_Dependence
                           then
                              Scan; -- past arrow
                              Rnam := P_Name;
                              Append_To (Expressions (Name_Node),
                                Make_Parameter_Association (Sloc (Rnam),
                                  Selector_Name             => Expr,
                                  Explicit_Actual_Parameter => Rnam));
                              exit;

                           --  For all other cases named notation is illegal

                           else
                              Error_Msg_SC
                                ("named parameters not permitted "
                                 & "for attributes");
                              Scan; -- past junk arrow
                           end if;

                        --  Here for normal case (not => for named parameter)

                        else
                           --  Special handling for 'Image in Ada 2012, where
                           --  the attribute can be parameterless and its value
                           --  can be the prefix of a slice. Rewrite name as a
                           --  slice, Expr is its low bound.

                           if Token = Tok_Dot_Dot
                             and then Attr_Name = Name_Image
                             and then Ada_Version >= Ada_2012
                           then
                              Set_Expressions (Name_Node, No_List);
                              Prefix_Node := Name_Node;
                              Name_Node :=
                                New_Node (N_Slice, Sloc (Prefix_Node));
                              Set_Prefix (Name_Node, Prefix_Node);
                              Range_Node := New_Node (N_Range, Token_Ptr);
                              Set_Low_Bound (Range_Node, Expr);
                              Scan; -- past ..
                              Expr_Node := P_Expression;
                              Check_Simple_Expression (Expr_Node);
                              Set_High_Bound (Range_Node, Expr_Node);
                              Set_Discrete_Range (Name_Node, Range_Node);
                              T_Right_Paren;

                              goto Scan_Name_Extension;

                           else
                              Append (Expr, Expressions (Name_Node));
                              exit when not Comma_Present;
                           end if;
                        end if;
                     end;
                  end loop;

                  T_Right_Paren;
               end if;
            end if;

            goto Scan_Name_Extension;
         end Scan_Apostrophe;

      --  Here for left parenthesis extending name (left paren skipped)

      <<Scan_Name_Extension_Left_Paren>>

         --  We now have to scan through a list of items, terminated by a
         --  right parenthesis. The scan is handled by a finite state
         --  machine. The possibilities are:

         --   (discrete_range)

         --      This is a slice. This case is handled in LP_State_Init

         --   (expression, expression, ..)

         --      This is interpreted as an indexed component, i.e. as a
         --      case of a name which can be extended in the normal manner.
         --      This case is handled by LP_State_Name or LP_State_Expr.

         --      (Ada 2020): the expression can be a reduction_expression_
         --      parameter, i.e. a box or < Simple_Expression >.

         --      Note: if and case expressions (without an extra level of
         --      parentheses) are permitted in this context).

         --   (..., identifier => expression , ...)

         --      If there is at least one occurrence of identifier => (but
         --      none of the other cases apply), then we have a call.

         --    < simple_expression >
         --    In Ada 2020 this is a reduction expression parameter that
         --    specifies the initial value of the reduction.

         --  Test for Id => case

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

            --  Test for => (allow := as an error substitute)

            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
               Restore_Scan_State (Scan_State); -- to Id
               Arg_List := New_List;
               goto LP_State_Call;

            else
               Restore_Scan_State (Scan_State); -- to Id
            end if;
         end if;

         --  Here we have an expression after all, which may be a reduction
         --  expression with a binary operator.

         if Token = Tok_Less then
            Scan; -- past <

            Expr_Node :=
              New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
            Set_Expression (Expr_Node, P_Simple_Expression);

            if Token = Tok_Greater then
               Scan;
            else
               Error_Msg_N
                 ("malformed reduction expression parameter", Expr_Node);
               raise Error_Resync;
            end if;

         else
            Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
         end if;

         --  Check cases of discrete range for a slice

         --  First possibility: Range_Attribute_Reference

         if Expr_Form = EF_Range_Attr then
            Range_Node := Expr_Node;

         --  Second possibility: 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 ..
            Expr_Node := P_Expression;
            Check_Simple_Expression (Expr_Node);
            Set_High_Bound (Range_Node, Expr_Node);

         --  Third possibility: Type_name range Range

         elsif Token = Tok_Range then
            if Expr_Form /= EF_Simple_Name then
               Error_Msg_SC ("subtype mark must precede RANGE");
               raise Error_Resync;
            end if;

            Range_Node := P_Subtype_Indication (Expr_Node);

         --  Otherwise we just have an expression. It is true that we might
         --  have a subtype mark without a range constraint but this case
         --  is syntactically indistinguishable from the expression case.

         else
            Arg_List := New_List;
            goto LP_State_Expr;
         end if;

         --  Fall through here with unmistakable Discrete range scanned,
         --  which means that we definitely have the case of a slice. The
         --  Discrete range is in Range_Node.

         if Token = Tok_Comma then
            Error_Msg_SC ("slice cannot have more than one dimension");
            raise Error_Resync;

         elsif Token /= Tok_Right_Paren then
            if Token = Tok_Arrow then

               --  This may be an aggregate that is missing a qualification

               Error_Msg_SC
                 ("context of aggregate must be a qualified expression");
               raise Error_Resync;

            else
               T_Right_Paren;
               raise Error_Resync;
            end if;

         else
            Scan; -- past right paren
            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Discrete_Range (Name_Node, Range_Node);

            --  An operator node is legal as a prefix to other names,
            --  but not for a slice.

            if Nkind (Prefix_Node) = N_Operator_Symbol then
               Error_Msg_N ("illegal prefix for slice", Prefix_Node);
            end if;

            --  If we have a name extension, go scan it

            if Token in Token_Class_Namext then
               goto Scan_Name_Extension_OK;

            --  Otherwise return (a slice is a name, but is not a call)

            else
               Expr_Form := EF_Name;
               return Name_Node;
            end if;
         end if;

      --  In LP_State_Expr, we have scanned one or more expressions, and
      --  so we have a call or an indexed component which is a name. On
      --  entry we have the expression just scanned in Expr_Node and
      --  Arg_List contains the list of expressions encountered so far

      <<LP_State_Expr>>
         Append (Expr_Node, Arg_List);

         if Token = Tok_Arrow then
            Error_Msg
              ("expect identifier in parameter association", Sloc (Expr_Node));
            Scan;  -- past arrow

         elsif not Comma_Present then
            T_Right_Paren;

            Prefix_Node := Name_Node;
            Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
            Set_Prefix (Name_Node, Prefix_Node);
            Set_Expressions (Name_Node, Arg_List);

            goto Scan_Name_Extension;
         end if;

         --  Comma present (and scanned out), test for identifier => case
         --  Test for identifier => case

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

            --  Test for => (allow := as error substitute)

            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
               Restore_Scan_State (Scan_State); -- to Id
               goto LP_State_Call;

            --  Otherwise it's just an expression after all, so backup

            else
               Restore_Scan_State (Scan_State); -- to Id
            end if;
         end if;

         --  Here we have an expression after all, so stay in this state

         Expr_Node := P_Expression_If_OK;
         goto LP_State_Expr;

      --  LP_State_Call corresponds to the situation in which at least one
      --  instance of Id => Expression has been encountered, so we know that
      --  we do not have a name, but rather a call. We enter it with the
      --  scan pointer pointing to the next argument to scan, and Arg_List
      --  containing the list of arguments scanned so far.

      <<LP_State_Call>>

         --  Test for case of Id => Expression (named parameter)

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

            --  Deal with => (allow := as incorrect substitute)

            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
               Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
               Set_Selector_Name (Arg_Node, Ident_Node);
               T_Arrow;
               Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
               Append (Arg_Node, Arg_List);

               --  If a comma follows, go back and scan next entry

               if Comma_Present then
                  goto LP_State_Call;

               --  Otherwise we have the end of a call

               else
                  Prefix_Node := Name_Node;
                  Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
                  Set_Name (Name_Node, Prefix_Node);
                  Set_Parameter_Associations (Name_Node, Arg_List);
                  T_Right_Paren;

                  if Token in Token_Class_Namext then
                     goto Scan_Name_Extension_OK;

                  --  This is a case of a call which cannot be a name

                  else
                     Expr_Form := EF_Name;
                     return Name_Node;
                  end if;
               end if;

            --  Not named parameter: Id started an expression after all

            else
               Restore_Scan_State (Scan_State); -- to Id
            end if;
         end if;

         --  Here if entry did not start with Id => which means that it
         --  is a positional parameter, which is not allowed, since we
         --  have seen at least one named parameter already.

         Error_Msg_SC
            ("positional parameter association " &
              "not allowed after named one");

         Expr_Node := P_Expression_If_OK;

         --  Leaving the '>' in an association is not unusual, so suggest
         --  a possible fix.

         if Nkind (Expr_Node) = N_Op_Eq then
            Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
         end if;

         --  We go back to scanning out expressions, so that we do not get
         --  multiple error messages when several positional parameters
         --  follow a named parameter.

         goto LP_State_Expr;

         --  End of treatment for name extensions starting with left paren

      --  End of loop through name extensions

   end P_Name;

   --  This function parses a restricted form of Names which are either
   --  designators, or designators preceded by a sequence of prefixes
   --  that are direct names.

   --  Error recovery: cannot raise Error_Resync

   function P_Function_Name return Node_Id is
      Designator_Node : Node_Id;
      Prefix_Node     : Node_Id;
      Selector_Node   : Node_Id;
      Dot_Sloc        : Source_Ptr := No_Location;

   begin
      --  Prefix_Node is set to the gathered prefix so far, Empty means that
      --  no prefix has been scanned. This allows us to build up the result
      --  in the required right recursive manner.

      Prefix_Node := Empty;

      --  Loop through prefixes

      loop
         Designator_Node := Token_Node;

         if Token not in Token_Class_Desig then
            return P_Identifier; -- let P_Identifier issue the error message

         else -- Token in Token_Class_Desig
            Scan; -- past designator
            exit when Token /= Tok_Dot;
         end if;

         --  Here at a dot, with token just before it in Designator_Node

         if No (Prefix_Node) then
            Prefix_Node := Designator_Node;
         else
            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
            Set_Prefix (Selector_Node, Prefix_Node);
            Set_Selector_Name (Selector_Node, Designator_Node);
            Prefix_Node := Selector_Node;
         end if;

         Dot_Sloc := Token_Ptr;
         Scan; -- past dot
      end loop;

      --  Fall out of the loop having just scanned a designator

      if No (Prefix_Node) then
         return Designator_Node;
      else
         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
         Set_Prefix (Selector_Node, Prefix_Node);
         Set_Selector_Name (Selector_Node, Designator_Node);
         return Selector_Node;
      end if;

   exception
      when Error_Resync =>
         return Error;
   end P_Function_Name;

   --  This function parses a restricted form of Names which are either
   --  identifiers, or identifiers preceded by a sequence of prefixes
   --  that are direct names.

   --  Error recovery: cannot raise Error_Resync

   function P_Qualified_Simple_Name return Node_Id is
      Designator_Node : Node_Id;
      Prefix_Node     : Node_Id;
      Selector_Node   : Node_Id;
      Dot_Sloc        : Source_Ptr := No_Location;

   begin
      --  Prefix node is set to the gathered prefix so far, Empty means that
      --  no prefix has been scanned. This allows us to build up the result
      --  in the required right recursive manner.

      Prefix_Node := Empty;

      --  Loop through prefixes

      loop
         Designator_Node := Token_Node;

         if Token = Tok_Identifier then
            Scan; -- past identifier
            exit when Token /= Tok_Dot;

         elsif Token not in Token_Class_Desig then
            return P_Identifier; -- let P_Identifier issue the error message

         else
            Scan; -- past designator

            if Token /= Tok_Dot then
               Error_Msg_SP ("identifier expected");
               return Error;
            end if;
         end if;

         --  Here at a dot, with token just before it in Designator_Node

         if No (Prefix_Node) then
            Prefix_Node := Designator_Node;
         else
            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
            Set_Prefix (Selector_Node, Prefix_Node);
            Set_Selector_Name (Selector_Node, Designator_Node);
            Prefix_Node := Selector_Node;
         end if;

         Dot_Sloc := Token_Ptr;
         Scan; -- past dot
      end loop;

      --  Fall out of the loop having just scanned an identifier

      if No (Prefix_Node) then
         return Designator_Node;
      else
         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
         Set_Prefix (Selector_Node, Prefix_Node);
         Set_Selector_Name (Selector_Node, Designator_Node);
         return Selector_Node;
      end if;

   exception
      when Error_Resync =>
         return Error;
   end P_Qualified_Simple_Name;

   --  This procedure differs from P_Qualified_Simple_Name only in that it
   --  raises Error_Resync if any error is encountered. It only returns after
   --  scanning a valid qualified simple name.

   --  Error recovery: can raise Error_Resync

   function P_Qualified_Simple_Name_Resync return Node_Id is
      Designator_Node : Node_Id;
      Prefix_Node     : Node_Id;
      Selector_Node   : Node_Id;
      Dot_Sloc        : Source_Ptr := No_Location;

   begin
      Prefix_Node := Empty;

      --  Loop through prefixes

      loop
         Designator_Node := Token_Node;

         if Token = Tok_Identifier then
            Scan; -- past identifier
            exit when Token /= Tok_Dot;

         elsif Token not in Token_Class_Desig then
            Discard_Junk_Node (P_Identifier); -- to issue the error message
            raise Error_Resync;

         else
            Scan; -- past designator

            if Token /= Tok_Dot then
               Error_Msg_SP ("identifier expected");
               raise Error_Resync;
            end if;
         end if;

         --  Here at a dot, with token just before it in Designator_Node

         if No (Prefix_Node) then
            Prefix_Node := Designator_Node;
         else
            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
            Set_Prefix (Selector_Node, Prefix_Node);
            Set_Selector_Name (Selector_Node, Designator_Node);
            Prefix_Node := Selector_Node;
         end if;

         Dot_Sloc := Token_Ptr;
         Scan; -- past period
      end loop;

      --  Fall out of the loop having just scanned an identifier

      if No (Prefix_Node) then
         return Designator_Node;
      else
         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
         Set_Prefix (Selector_Node, Prefix_Node);
         Set_Selector_Name (Selector_Node, Designator_Node);
         return Selector_Node;
      end if;
   end P_Qualified_Simple_Name_Resync;

   ----------------------
   -- 4.1  Direct_Name --
   ----------------------

   --  Parsed by P_Name and other functions in section 4.1

   -----------------
   -- 4.1  Prefix --
   -----------------

   --  Parsed by P_Name (4.1)

   -------------------------------
   -- 4.1  Explicit Dereference --
   -------------------------------

   --  Parsed by P_Name (4.1)

   -------------------------------
   -- 4.1  Implicit_Dereference --
   -------------------------------

   --  Parsed by P_Name (4.1)

   ----------------------------
   -- 4.1  Indexed Component --
   ----------------------------

   --  Parsed by P_Name (4.1)

   ----------------
   -- 4.1  Slice --
   ----------------

   --  Parsed by P_Name (4.1)

   -----------------------------
   -- 4.1  Selected_Component --
   -----------------------------

   --  Parsed by P_Name (4.1)

   ------------------------
   -- 4.1  Selector Name --
   ------------------------

   --  Parsed by P_Name (4.1)

   ------------------------------
   -- 4.1  Attribute Reference --
   ------------------------------

   --  Parsed by P_Name (4.1)

   -------------------------------
   -- 4.1  Attribute Designator --
   -------------------------------

   --  Parsed by P_Name (4.1)

   --------------------------------------
   -- 4.1.4  Range Attribute Reference --
   --------------------------------------

   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR

   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]

   --  In the grammar, a RANGE attribute is simply a name, but its use is
   --  highly restricted, so in the parser, we do not regard it as a name.
   --  Instead, P_Name returns without scanning the 'RANGE part of the
   --  attribute, and the caller uses the following function to construct
   --  a range attribute in places where it is appropriate.

   --  Note that RANGE here is treated essentially as an identifier,
   --  rather than a reserved word.

   --  The caller has parsed the prefix, i.e. a name, and Token points to
   --  the apostrophe. The token after the apostrophe is known to be RANGE
   --  at this point. The prefix node becomes the prefix of the attribute.

   --  Error_Recovery: Cannot raise Error_Resync

   function P_Range_Attribute_Reference
     (Prefix_Node : Node_Id)
      return        Node_Id
   is
      Attr_Node  : Node_Id;

   begin
      Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
      Set_Prefix (Attr_Node, Prefix_Node);
      Scan; -- past apostrophe

      if Style_Check then
         Style.Check_Attribute_Name (True);
      end if;

      Set_Attribute_Name (Attr_Node, Name_Range);
      Scan; -- past RANGE

      if Token = Tok_Left_Paren then
         Scan; -- past left paren
         Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
         T_Right_Paren;
      end if;

      return Attr_Node;
   end P_Range_Attribute_Reference;

   ---------------------------------------
   -- 4.1.4  Range Attribute Designator --
   ---------------------------------------

   --  Parsed by P_Range_Attribute_Reference (4.4)

   --------------------
   -- 4.3  Aggregate --
   --------------------

   --  AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
   --  an aggregate is known to be required (code statement, extension
   --  aggregate), in which cases this routine performs the necessary check
   --  that we have an aggregate rather than a parenthesized expression

   --  Error recovery: can raise Error_Resync

   function P_Aggregate return Node_Id is
      Aggr_Sloc : constant Source_Ptr := Token_Ptr;
      Aggr_Node : constant Node_Id    := P_Aggregate_Or_Paren_Expr;

   begin
      if Nkind (Aggr_Node) /= N_Aggregate
           and then
         Nkind (Aggr_Node) /= N_Extension_Aggregate
      then
         Error_Msg
           ("aggregate may not have single positional component", Aggr_Sloc);
         return Error;
      else
         return Aggr_Node;
      end if;
   end P_Aggregate;

   ------------------------------------------------
   -- 4.3  Aggregate or Parenthesized Expression --
   ------------------------------------------------

   --  This procedure parses out either an aggregate or a parenthesized
   --  expression (these two constructs are closely related, since a
   --  parenthesized expression looks like an aggregate with a single
   --  positional component).

   --  AGGREGATE ::=
   --    RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE

   --  RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)

   --  RECORD_COMPONENT_ASSOCIATION_LIST ::=
   --     RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
   --   | null record

   --  RECORD_COMPONENT_ASSOCIATION ::=
   --    [COMPONENT_CHOICE_LIST =>] EXPRESSION

   --  COMPONENT_CHOICE_LIST ::=
   --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
   --  | others

   --  EXTENSION_AGGREGATE ::=
   --    (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)

   --  ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK

   --  ARRAY_AGGREGATE ::=
   --    POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE

   --  POSITIONAL_ARRAY_AGGREGATE ::=
   --    (EXPRESSION, EXPRESSION {, EXPRESSION})
   --  | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
   --  | (EXPRESSION {, EXPRESSION}, others => <>)

   --  NAMED_ARRAY_AGGREGATE ::=
   --    (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})

   --  PRIMARY ::= (EXPRESSION);

   --  Error recovery: can raise Error_Resync

   --  Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
   --        to Ada 2005 limited aggregates (AI-287)

   function P_Aggregate_Or_Paren_Expr return Node_Id is
      Aggregate_Node : Node_Id;
      Expr_List      : List_Id;
      Assoc_List     : List_Id;
      Expr_Node      : Node_Id;
      Lparen_Sloc    : Source_Ptr;
      Scan_State     : Saved_Scan_State;

      procedure Box_Error;
      --  Called if <> is encountered as positional aggregate element. Issues
      --  error message and sets Expr_Node to Error.

      function Is_Quantified_Expression return Boolean;
      --  The presence of iterated component associations requires a one
      --  token lookahead to distinguish it from quantified expressions.

      ---------------
      -- Box_Error --
      ---------------

      procedure Box_Error is
      begin
         if Ada_Version < Ada_2005 then
            Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
         end if;

         --  Ada 2005 (AI-287): The box notation is allowed only with named
         --  notation because positional notation might be error prone. For
         --  example, in "(X, <>, Y, <>)", there is no type associated with
         --  the boxes, so you might not be leaving out the components you
         --  thought you were leaving out.

         Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
         Scan; -- past box
         Expr_Node := Error;
      end Box_Error;

      ------------------------------
      -- Is_Quantified_Expression --
      ------------------------------

      function Is_Quantified_Expression return Boolean is
         Maybe      : Boolean;
         Scan_State : Saved_Scan_State;

      begin
         Save_Scan_State (Scan_State);
         Scan;   --  past FOR
         Maybe := Token = Tok_All or else Token = Tok_Some;
         Restore_Scan_State (Scan_State);  --  to FOR
         return Maybe;
      end Is_Quantified_Expression;

   --  Start of processing for P_Aggregate_Or_Paren_Expr

   begin
      Lparen_Sloc := Token_Ptr;
      T_Left_Paren;

      --  Note on parentheses count. For cases like an if expression, the
      --  parens here really count as real parentheses for the paren count,
      --  so we adjust the paren count accordingly after scanning the expr.

      --  If expression

      if Token = Tok_If then
         Expr_Node := P_If_Expression;
         T_Right_Paren;
         Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
         return Expr_Node;

      --  Case expression

      elsif Token = Tok_Case then
         Expr_Node := P_Case_Expression;
         T_Right_Paren;
         Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
         return Expr_Node;

      --  Quantified expression

      elsif Token = Tok_For and then Is_Quantified_Expression then
         Expr_Node := P_Quantified_Expression;
         T_Right_Paren;
         Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
         return Expr_Node;

      --  Note: the mechanism used here of rescanning the initial expression
      --  is distinctly unpleasant, but it saves a lot of fiddling in scanning
      --  out the discrete choice list.

      --  Deal with expression and extension aggregates first

      elsif Token /= Tok_Others then
         Save_Scan_State (Scan_State); -- at start of expression

         --  Deal with (NULL RECORD)

         if Token = Tok_Null then
            Scan; -- past NULL

            if Token = Tok_Record then
               Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
               Set_Null_Record_Present (Aggregate_Node, True);
               Scan; -- past RECORD
               T_Right_Paren;
               return Aggregate_Node;
            else
               Restore_Scan_State (Scan_State); -- to NULL that must be expr
            end if;

         elsif Token = Tok_For then
            Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
            Expr_Node := P_Iterated_Component_Assoc_Or_Reduction;

            if Nkind (Expr_Node) = N_Reduction_Expression then
               return Expr_Node;
            else
               goto Aggregate;
            end if;
         end if;

         --  Scan expression, handling box appearing as positional argument

         if Token = Tok_Box then
            Box_Error;
         else
            Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
         end if;

         --  Extension or Delta aggregate

         if Token = Tok_With then
            if Nkind (Expr_Node) = N_Attribute_Reference
              and then Attribute_Name (Expr_Node) = Name_Range
            then
               Bad_Range_Attribute (Sloc (Expr_Node));
               return Error;
            end if;

            if Ada_Version = Ada_83 then
               Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
            end if;

            Scan; -- past WITH
            if Token = Tok_Delta then
               Scan; -- past DELTA
               Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
               Set_Expression (Aggregate_Node, Expr_Node);
               Expr_Node := Empty;

               if Nkind (Aggregate_Node) = N_Delta_Aggregate
                 and then (Token = Tok_Arrow or else Token = Tok_Others)
               then
                  Error_Msg_SC
                    ("expect record component association in delta aggregate");
                  raise Error_Resync;
               end if;

               goto Aggregate;

            else
               Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
               Set_Ancestor_Part (Aggregate_Node, Expr_Node);
            end if;

            --  Deal with WITH NULL RECORD case

            if Token = Tok_Null then
               Save_Scan_State (Scan_State); -- at NULL
               Scan; -- past NULL

               if Token = Tok_Record then
                  Scan; -- past RECORD
                  Set_Null_Record_Present (Aggregate_Node, True);
                  T_Right_Paren;
                  return Aggregate_Node;

               else
                  Restore_Scan_State (Scan_State); -- to NULL that must be expr
               end if;
            end if;

            if Token /= Tok_Others then
               Save_Scan_State (Scan_State);
               Expr_Node := P_Expression;
            else
               Expr_Node := Empty;
            end if;

         --  Expression

         elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
            if Nkind (Expr_Node) = N_Attribute_Reference
              and then Attribute_Name (Expr_Node) = Name_Range
            then
               Error_Msg
                 ("|parentheses not allowed for range attribute", Lparen_Sloc);
               Scan; -- past right paren
               return Expr_Node;
            end if;

            --  Bump paren count of expression

            if Expr_Node /= Error then
               Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
            end if;

            T_Right_Paren; -- past right paren (error message if none)
            return Expr_Node;

         --  Normal aggregate

         else
            Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
         end if;

      --  Others

      else
         Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
         Expr_Node := Empty;
      end if;

      --  Prepare to scan list of component associations
      <<Aggregate>>
      Expr_List  := No_List; -- don't set yet, maybe all named entries
      Assoc_List := No_List; -- don't set yet, maybe all positional entries

      --  This loop scans through component associations. On entry to the
      --  loop, an expression has been scanned at the start of the current
      --  association unless initial token was OTHERS, in which case
      --  Expr_Node is set to Empty.

      loop
         --  Deal with others association first. This is a named association

         if No (Expr_Node) then
            if No (Assoc_List) then
               Assoc_List := New_List;
            end if;

            Append (P_Record_Or_Array_Component_Association, Assoc_List);

         --  Improper use of WITH

         elsif Token = Tok_With then
            Error_Msg_SC ("WITH must be preceded by single expression in " &
                             "extension aggregate");
            raise Error_Resync;

         --  Range attribute can only appear as part of a discrete choice list

         elsif Nkind (Expr_Node) = N_Attribute_Reference
           and then Attribute_Name (Expr_Node) = Name_Range
           and then Token /= Tok_Arrow
           and then Token /= Tok_Vertical_Bar
         then
            Bad_Range_Attribute (Sloc (Expr_Node));
            return Error;

         --  Assume positional case if comma, right paren, or literal or
         --  identifier or OTHERS follows (the latter cases are missing
         --  comma cases). Also assume positional if a semicolon follows,
         --  which can happen if there are missing parens.

         elsif Nkind (Expr_Node) = N_Iterated_Component_Association then
            if No (Assoc_List) then
               Assoc_List := New_List (Expr_Node);
            else
               Append_To (Assoc_List, Expr_Node);
            end if;

         elsif Token = Tok_Comma
           or else Token = Tok_Right_Paren
           or else Token = Tok_Others
           or else Token in Token_Class_Lit_Or_Name
           or else Token = Tok_Semicolon
         then
            if Present (Assoc_List) then
               Error_Msg_BC -- CODEFIX
                 ("""='>"" expected (positional association cannot follow "
                  & "named association)");
            end if;

            if No (Expr_List) then
               Expr_List := New_List;
            end if;

            Append (Expr_Node, Expr_List);

         --  Check for aggregate followed by left parent, maybe missing comma

         elsif Nkind (Expr_Node) = N_Aggregate
           and then Token = Tok_Left_Paren
         then
            T_Comma;

            if No (Expr_List) then
               Expr_List := New_List;
            end if;

            Append (Expr_Node, Expr_List);

         --  Anything else is assumed to be a named association

         else
            Restore_Scan_State (Scan_State); -- to start of expression

            if No (Assoc_List) then
               Assoc_List := New_List;
            end if;

            Append (P_Record_Or_Array_Component_Association, Assoc_List);
         end if;

         exit when not Comma_Present;

         --  If we are at an expression terminator, something is seriously
         --  wrong, so let's get out now, before we start eating up stuff
         --  that doesn't belong to us.

         if Token in Token_Class_Eterm and then Token /= Tok_For then
            Error_Msg_AP
              ("expecting expression or component association");
            exit;
         end if;

         --  Deal with misused box

         if Token = Tok_Box then
            Box_Error;

         --  Otherwise initiate for reentry to top of loop by scanning an
         --  initial expression, unless the first token is OTHERS or FOR,
         --  which indicates an iterated component association.

         elsif Token = Tok_Others then
            Expr_Node := Empty;

         elsif Token = Tok_For then
            Expr_Node := P_Iterated_Component_Assoc_Or_Reduction;

         else
            Save_Scan_State (Scan_State); -- at start of expression
            Expr_Node := P_Expression_Or_Range_Attribute_If_OK;

         end if;
      end loop;

      --  All component associations (positional and named) have been scanned

      T_Right_Paren;

      if Nkind (Aggregate_Node) /= N_Delta_Aggregate then
         Set_Expressions (Aggregate_Node, Expr_List);
      end if;

      Set_Component_Associations (Aggregate_Node, Assoc_List);
      return Aggregate_Node;
   end P_Aggregate_Or_Paren_Expr;

   ------------------------------------------------
   -- 4.3  Record or Array Component Association --
   ------------------------------------------------

   --  RECORD_COMPONENT_ASSOCIATION ::=
   --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
   --  | COMPONENT_CHOICE_LIST => <>

   --  COMPONENT_CHOICE_LIST =>
   --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
   --  | others

   --  ARRAY_COMPONENT_ASSOCIATION ::=
   --    DISCRETE_CHOICE_LIST => EXPRESSION
   --  | DISCRETE_CHOICE_LIST => <>
   --  | ITERATED_COMPONENT_ASSOCIATION

   --  Note: this routine only handles the named cases, including others.
   --  Cases where the component choice list is not present have already
   --  been handled directly.

   --  Error recovery: can raise Error_Resync

   --  Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
   --        rules have been extended to give support to Ada 2005 limited
   --        aggregates (AI-287)

   function P_Record_Or_Array_Component_Association return Node_Id is
      Assoc_Node : Node_Id;

   begin
      if Token = Tok_For then
         return P_Iterated_Component_Assoc_Or_Reduction;
      end if;

      Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
      Set_Choices (Assoc_Node, P_Discrete_Choice_List);
      Set_Sloc (Assoc_Node, Token_Ptr);
      TF_Arrow;

      if Token = Tok_Box then

         --  Ada 2005(AI-287): The box notation is used to indicate the
         --  default initialization of aggregate components

         if Ada_Version < Ada_2005 then
            Error_Msg_SP
              ("component association with '<'> is an Ada 2005 extension");
            Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
         end if;

         Set_Box_Present (Assoc_Node);
         Scan; -- Past box
      else
         Set_Expression (Assoc_Node, P_Expression);
      end if;

      return Assoc_Node;
   end P_Record_Or_Array_Component_Association;

   -----------------------------
   -- 4.3.1  Record Aggregate --
   -----------------------------

   --  Case of enumeration aggregate is parsed by P_Aggregate (4.3)
   --  All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ----------------------------------------------
   -- 4.3.1  Record Component Association List --
   ----------------------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ----------------------------------
   -- 4.3.1  Component Choice List --
   ----------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   --------------------------------
   -- 4.3.1  Extension Aggregate --
   --------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   --------------------------
   -- 4.3.1  Ancestor Part --
   --------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ----------------------------
   -- 4.3.1  Array Aggregate --
   ----------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ---------------------------------------
   -- 4.3.1  Positional Array Aggregate --
   ---------------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ----------------------------------
   -- 4.3.1  Named Array Aggregate --
   ----------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ----------------------------------------
   -- 4.3.1  Array Component Association --
   ----------------------------------------

   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)

   ---------------------
   -- 4.4  Expression --
   ---------------------

   --  This procedure parses EXPRESSION or CHOICE_EXPRESSION

   --  EXPRESSION ::=
   --    RELATION {LOGICAL_OPERATOR RELATION}

   --  CHOICE_EXPRESSION ::=
   --    CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}

   --  LOGICAL_OPERATOR ::= and | and then | or | or else | xor

   --  On return, Expr_Form indicates the categorization of the expression
   --  EF_Range_Attr is not a possible value (if a range attribute is found,
   --  an error message is given, and Error is returned).

   --  Error recovery: cannot raise Error_Resync

   function P_Expression return Node_Id is
      Logical_Op      : Node_Kind;
      Prev_Logical_Op : Node_Kind;
      Op_Location     : Source_Ptr;
      Node1           : Node_Id;
      Node2           : Node_Id;

   begin
      Node1 := P_Relation;

      if Token in Token_Class_Logop then
         Prev_Logical_Op := N_Empty;

         loop
            Op_Location := Token_Ptr;
            Logical_Op := P_Logical_Operator;

            if Prev_Logical_Op /= N_Empty and then
               Logical_Op /= Prev_Logical_Op
            then
               Error_Msg
                 ("mixed logical operators in expression", Op_Location);
               Prev_Logical_Op := N_Empty;
            else
               Prev_Logical_Op := Logical_Op;
            end if;

            Node2 := Node1;
            Node1 := New_Op_Node (Logical_Op, Op_Location);
            Set_Left_Opnd (Node1, Node2);
            Set_Right_Opnd (Node1, P_Relation);

            --  Check for case of errant comma or semicolon

            if Token = Tok_Comma or else Token = Tok_Semicolon then
               declare
                  Com        : constant Boolean := Token = Tok_Comma;
                  Scan_State : Saved_Scan_State;
                  Logop      : Node_Kind;

               begin
                  Save_Scan_State (Scan_State); -- at comma/semicolon
                  Scan; -- past comma/semicolon

                  --  Check for AND THEN or OR ELSE after comma/semicolon. We
                  --  do not deal with AND/OR because those cases get mixed up
                  --  with the select alternatives case.

                  if Token = Tok_And or else Token = Tok_Or then
                     Logop := P_Logical_Operator;
                     Restore_Scan_State (Scan_State); -- to comma/semicolon

                     if Nkind_In (Logop, N_And_Then, N_Or_Else) then
                        Scan; -- past comma/semicolon

                        if Com then
                           Error_Msg_SP -- CODEFIX
                             ("|extra "","" ignored");
                        else
                           Error_Msg_SP -- CODEFIX
                             ("|extra "";"" ignored");
                        end if;

                     else
                        Restore_Scan_State (Scan_State); -- to comma/semicolon
                     end if;

                  else
                     Restore_Scan_State (Scan_State); -- to comma/semicolon
                  end if;
               end;
            end if;

            exit when Token not in Token_Class_Logop;
         end loop;

         Expr_Form := EF_Non_Simple;
      end if;

      if Token = Tok_Apostrophe then
         Bad_Range_Attribute (Token_Ptr);
         return Error;
      else
         return Node1;
      end if;
   end P_Expression;

   --  This function is identical to the normal P_Expression, except that it
   --  also permits the appearance of a case, conditional, or quantified
   --  expression if the call immediately follows a left paren, and followed
   --  by a right parenthesis. These forms are allowed if these conditions
   --  are not met, but an error message will be issued.

   function P_Expression_If_OK return Node_Id is
   begin
      --  Case of conditional, case or quantified expression

      if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
         return P_Unparen_Cond_Case_Quant_Expression;

      --  Normal case, not case/conditional/quantified expression

      else
         return P_Expression;
      end if;
   end P_Expression_If_OK;

   --  This function is identical to the normal P_Expression, except that it
   --  checks that the expression scan did not stop on a right paren. It is
   --  called in all contexts where a right parenthesis cannot legitimately
   --  follow an expression.

   --  Error recovery: can not raise Error_Resync

   function P_Expression_No_Right_Paren return Node_Id is
      Expr : constant Node_Id := P_Expression;
   begin
      Ignore (Tok_Right_Paren);
      return Expr;
   end P_Expression_No_Right_Paren;

   ----------------------------------------
   -- 4.4  Expression_Or_Range_Attribute --
   ----------------------------------------

   --  EXPRESSION ::=
   --    RELATION {and RELATION} | RELATION {and then RELATION}
   --  | RELATION {or RELATION}  | RELATION {or else RELATION}
   --  | RELATION {xor RELATION}

   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR

   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]

   --  On return, Expr_Form indicates the categorization of the expression
   --  and EF_Range_Attr is one of the possibilities.

   --  Error recovery: cannot raise Error_Resync

   --  In the grammar, a RANGE attribute is simply a name, but its use is
   --  highly restricted, so in the parser, we do not regard it as a name.
   --  Instead, P_Name returns without scanning the 'RANGE part of the
   --  attribute, and P_Expression_Or_Range_Attribute handles the range
   --  attribute reference. In the normal case where a range attribute is
   --  not allowed, an error message is issued by P_Expression.

   function P_Expression_Or_Range_Attribute return Node_Id is
      Logical_Op      : Node_Kind;
      Prev_Logical_Op : Node_Kind;
      Op_Location     : Source_Ptr;
      Node1           : Node_Id;
      Node2           : Node_Id;
      Attr_Node       : Node_Id;

   begin
      Node1 := P_Relation;

      if Token = Tok_Apostrophe then
         Attr_Node := P_Range_Attribute_Reference (Node1);
         Expr_Form := EF_Range_Attr;
         return Attr_Node;

      elsif Token in Token_Class_Logop then
         Prev_Logical_Op := N_Empty;

         loop
            Op_Location := Token_Ptr;
            Logical_Op := P_Logical_Operator;

            if Prev_Logical_Op /= N_Empty and then
               Logical_Op /= Prev_Logical_Op
            then
               Error_Msg
                 ("mixed logical operators in expression", Op_Location);
               Prev_Logical_Op := N_Empty;
            else
               Prev_Logical_Op := Logical_Op;
            end if;

            Node2 := Node1;
            Node1 := New_Op_Node (Logical_Op, Op_Location);
            Set_Left_Opnd (Node1, Node2);
            Set_Right_Opnd (Node1, P_Relation);
            exit when Token not in Token_Class_Logop;
         end loop;

         Expr_Form := EF_Non_Simple;
      end if;

      if Token = Tok_Apostrophe then
         Bad_Range_Attribute (Token_Ptr);
         return Error;
      else
         return Node1;
      end if;
   end P_Expression_Or_Range_Attribute;

   --  Version that allows a non-parenthesized case, conditional, or quantified
   --  expression if the call immediately follows a left paren, and followed
   --  by a right parenthesis. These forms are allowed if these conditions
   --  are not met, but an error message will be issued.

   function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
   begin
      --  Case of conditional, case or quantified expression

      if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
         return P_Unparen_Cond_Case_Quant_Expression;

      --  Normal case, not one of the above expression types

      else
         return P_Expression_Or_Range_Attribute;
      end if;
   end P_Expression_Or_Range_Attribute_If_OK;

   -------------------
   -- 4.4  Relation --
   -------------------

   --  This procedure scans both relations and choice relations

   --  CHOICE_RELATION ::=
   --    SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]

   --  RELATION ::=
   --    SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
   --  | RAISE_EXPRESSION

   --  MEMBERSHIP_CHOICE_LIST ::=
   --    MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}

   --  MEMBERSHIP_CHOICE ::=
   --    CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK

   --  RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]

   --  On return, Expr_Form indicates the categorization of the expression

   --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
   --  EF_Simple_Name and the following token is RANGE (range attribute case).

   --  Error recovery: cannot raise Error_Resync. If an error occurs within an
   --  expression, then tokens are scanned until either a non-expression token,
   --  a right paren (not matched by a left paren) or a comma, is encountered.

   function P_Relation return Node_Id is
      Node1, Node2 : Node_Id;
      Optok        : Source_Ptr;

   begin
      --  First check for raise expression

      if Token = Tok_Raise then
         Expr_Form := EF_Non_Simple;
         return P_Raise_Expression;
      end if;

      --  All other cases

      Node1 := P_Simple_Expression;

      if Token not in Token_Class_Relop then
         return Node1;

      else
         --  Here we have a relational operator following. If so then scan it
         --  out. Note that the assignment symbol := is treated as a relational
         --  operator to improve the error recovery when it is misused for =.
         --  P_Relational_Operator also parses the IN and NOT IN operations.

         Optok := Token_Ptr;
         Node2 := New_Op_Node (P_Relational_Operator, Optok);
         Set_Left_Opnd (Node2, Node1);

         --  Case of IN or NOT IN

         if Prev_Token = Tok_In then
            P_Membership_Test (Node2);

         --  Case of relational operator (= /= < <= > >=)

         else
            Set_Right_Opnd (Node2, P_Simple_Expression);
         end if;

         Expr_Form := EF_Non_Simple;

         if Token in Token_Class_Relop then
            Error_Msg_SC ("unexpected relational operator");
            raise Error_Resync;
         end if;

         return Node2;
      end if;

   --  If any error occurs, then scan to the next expression terminator symbol
   --  or comma or right paren at the outer (i.e. current) parentheses level.
   --  The flags are set to indicate a normal simple expression.

   exception
      when Error_Resync =>
         Resync_Expression;
         Expr_Form := EF_Simple;
         return Error;
   end P_Relation;

   ----------------------------
   -- 4.4  Simple Expression --
   ----------------------------

   --  SIMPLE_EXPRESSION ::=
   --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}

   --  On return, Expr_Form indicates the categorization of the expression

   --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
   --  EF_Simple_Name and the following token is RANGE (range attribute case).

   --  Error recovery: cannot raise Error_Resync. If an error occurs within an
   --  expression, then tokens are scanned until either a non-expression token,
   --  a right paren (not matched by a left paren) or a comma, is encountered.

   --  Note: P_Simple_Expression is called only internally by higher level
   --  expression routines. In cases in the grammar where a simple expression
   --  is required, the approach is to scan an expression, and then post an
   --  appropriate error message if the expression obtained is not simple. This
   --  gives better error recovery and treatment.

   function P_Simple_Expression return Node_Id is
      Scan_State : Saved_Scan_State;
      Node1      : Node_Id;
      Node2      : Node_Id;
      Tokptr     : Source_Ptr;

      function At_Start_Of_Attribute return Boolean;
      --  Tests if we have quote followed by attribute name, if so, return True
      --  otherwise return False.

      ---------------------------
      -- At_Start_Of_Attribute --
      ---------------------------

      function At_Start_Of_Attribute return Boolean is
      begin
         if Token /= Tok_Apostrophe then
            return False;

         else
            declare
               Scan_State : Saved_Scan_State;

            begin
               Save_Scan_State (Scan_State);
               Scan; -- past quote

               if Token = Tok_Identifier
                 and then Is_Attribute_Name (Chars (Token_Node))
               then
                  Restore_Scan_State (Scan_State);
                  return True;
               else
                  Restore_Scan_State (Scan_State);
                  return False;
               end if;
            end;
         end if;
      end At_Start_Of_Attribute;

   --  Start of processing for P_Simple_Expression

   begin
      --  Check for cases starting with a name. There are two reasons for
      --  special casing. First speed things up by catching a common case
      --  without going through several routine layers. Second the caller must
      --  be informed via Expr_Form when the simple expression is a name.

      if Token in Token_Class_Name then
         Node1 := P_Name;

         --  Deal with apostrophe cases

         if Token = Tok_Apostrophe then
            Save_Scan_State (Scan_State); -- at apostrophe
            Scan; -- past apostrophe

            --  If qualified expression, scan it out and fall through

            if Token = Tok_Left_Paren then
               Node1 := P_Qualified_Expression (Node1);
               Expr_Form := EF_Simple;

            --  If range attribute, then we return with Token pointing to the
            --  apostrophe. Note: avoid the normal error check on exit. We
            --  know that the expression really is complete in this case.

            else -- Token = Tok_Range then
               Restore_Scan_State (Scan_State); -- to apostrophe
               Expr_Form := EF_Simple_Name;
               return Node1;
            end if;
         end if;

         --  If an expression terminator follows, the previous processing
         --  completely scanned out the expression (a common case), and
         --  left Expr_Form set appropriately for returning to our caller.

         if Token in Token_Class_Sterm then
            null;

         --  If we do not have an expression terminator, then complete the
         --  scan of a simple expression. This code duplicates the code
         --  found in P_Term and P_Factor.

         else
            if Token = Tok_Double_Asterisk then
               if Style_Check then
                  Style.Check_Exponentiation_Operator;
               end if;

               Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
               Scan; -- past **
               Set_Left_Opnd (Node2, Node1);
               Set_Right_Opnd (Node2, P_Primary);
               Check_Bad_Exp;
               Node1 := Node2;
            end if;

            loop
               exit when Token not in Token_Class_Mulop;
               Tokptr := Token_Ptr;
               Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);

               if Style_Check then
                  Style.Check_Binary_Operator;
               end if;

               Scan; -- past operator
               Set_Left_Opnd (Node2, Node1);
               Set_Right_Opnd (Node2, P_Factor);
               Node1 := Node2;
            end loop;

            loop
               exit when Token not in Token_Class_Binary_Addop;
               Tokptr := Token_Ptr;
               Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);

               if Style_Check then
                  Style.Check_Binary_Operator;
               end if;

               Scan; -- past operator
               Set_Left_Opnd (Node2, Node1);
               Set_Right_Opnd (Node2, P_Term);
               Node1 := Node2;
            end loop;

            Expr_Form := EF_Simple;
         end if;

      --  Cases where simple expression does not start with a name

      else
         --  Scan initial sign and initial Term

         if Token in Token_Class_Unary_Addop then
            Tokptr := Token_Ptr;
            Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);

            if Style_Check then
               Style.Check_Unary_Plus_Or_Minus (Inside_Depends);
            end if;

            Scan; -- past operator
            Set_Right_Opnd (Node1, P_Term);
         else
            Node1 := P_Term;
         end if;

         --  In the following, we special-case a sequence of concatenations of
         --  string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
         --  else mixed in. For such a sequence, we return a tree representing
         --  "" & "aaabbb...ccc" (a single concatenation). This is done only if
         --  the number of concatenations is large. If semantic analysis
         --  resolves the "&" to a predefined one, then this folding gives the
         --  right answer. Otherwise, semantic analysis will complain about a
         --  capacity-exceeded error. The purpose of this trick is to avoid
         --  creating a deeply nested tree, which would cause deep recursion
         --  during semantics, causing stack overflow. This way, we can handle
         --  enormous concatenations in the normal case of predefined "&".  We
         --  first build up the normal tree, and then rewrite it if
         --  appropriate.

         declare
            Num_Concats_Threshold : constant Positive := 1000;
            --  Arbitrary threshold value to enable optimization

            First_Node : constant Node_Id := Node1;
            Is_Strlit_Concat : Boolean;
            --  True iff we've parsed a sequence of concatenations of string
            --  literals, with nothing else mixed in.

            Num_Concats : Natural;
            --  Number of "&" operators if Is_Strlit_Concat is True

         begin
            Is_Strlit_Concat :=
              Nkind (Node1) = N_String_Literal
                and then Token = Tok_Ampersand;
            Num_Concats := 0;

            --  Scan out sequence of terms separated by binary adding operators

            loop
               exit when Token not in Token_Class_Binary_Addop;
               Tokptr := Token_Ptr;
               Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);

               if Style_Check and then not Debug_Flag_Dot_QQ then
                  Style.Check_Binary_Operator;
               end if;

               Scan; -- past operator
               Set_Left_Opnd (Node2, Node1);
               Node1 := P_Term;
               Set_Right_Opnd (Node2, Node1);

               --  Check if we're still concatenating string literals

               Is_Strlit_Concat :=
                 Is_Strlit_Concat
                   and then Nkind (Node2) = N_Op_Concat
                 and then Nkind (Node1) = N_String_Literal;

               if Is_Strlit_Concat then
                  Num_Concats := Num_Concats + 1;
               end if;

               Node1 := Node2;
            end loop;

            --  If we have an enormous series of concatenations of string
            --  literals, rewrite as explained above. The Is_Folded_In_Parser
            --  flag tells semantic analysis that if the "&" is not predefined,
            --  the folded value is wrong.

            if Is_Strlit_Concat
              and then Num_Concats >= Num_Concats_Threshold
            then
               declare
                  Empty_String_Val : String_Id;
                  --  String_Id for ""

                  Strlit_Concat_Val : String_Id;
                  --  Contains the folded value (which will be correct if the
                  --  "&" operators are the predefined ones).

                  Cur_Node : Node_Id;
                  --  For walking up the tree

                  New_Node : Node_Id;
                  --  Folded node to replace Node1

                  Loc : constant Source_Ptr := Sloc (First_Node);

               begin
                  --  Walk up the tree starting at the leftmost string literal
                  --  (First_Node), building up the Strlit_Concat_Val as we
                  --  go. Note that we do not use recursion here -- the whole
                  --  point is to avoid recursively walking that enormous tree.

                  Start_String;
                  Store_String_Chars (Strval (First_Node));

                  Cur_Node := Parent (First_Node);
                  while Present (Cur_Node) loop
                     pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
                        Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);

                     Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
                     Cur_Node := Parent (Cur_Node);
                  end loop;

                  Strlit_Concat_Val := End_String;

                  --  Create new folded node, and rewrite result with a concat-
                  --  enation of an empty string literal and the folded node.

                  Start_String;
                  Empty_String_Val := End_String;
                  New_Node :=
                    Make_Op_Concat (Loc,
                      Make_String_Literal (Loc, Empty_String_Val),
                      Make_String_Literal (Loc, Strlit_Concat_Val,
                        Is_Folded_In_Parser => True));
                  Rewrite (Node1, New_Node);
               end;
            end if;
         end;

         --  All done, we clearly do not have name or numeric literal so this
         --  is a case of a simple expression which is some other possibility.

         Expr_Form := EF_Simple;
      end if;

      --  Come here at end of simple expression, where we do a couple of
      --  special checks to improve error recovery.

      --  Special test to improve error recovery. If the current token is a
      --  period, then someone is trying to do selection on something that is
      --  not a name, e.g. a qualified expression.

      if Token = Tok_Dot then
         Error_Msg_SC ("prefix for selection is not a name");

         --  If qualified expression, comment and continue, otherwise something
         --  is pretty nasty so do an Error_Resync call.

         if Ada_Version < Ada_2012
           and then Nkind (Node1) = N_Qualified_Expression
         then
            Error_Msg_SC ("\would be legal in Ada 2012 mode");
         else
            raise Error_Resync;
         end if;
      end if;

      --  Special test to improve error recovery: If the current token is
      --  not the first token on a line (as determined by checking the
      --  previous token position with the start of the current line),
      --  then we insist that we have an appropriate terminating token.
      --  Consider the following two examples:

      --   1)  if A nad B then ...

      --   2)  A := B
      --       C := D

      --  In the first example, we would like to issue a binary operator
      --  expected message and resynchronize to the then. In the second
      --  example, we do not want to issue a binary operator message, so
      --  that instead we will get the missing semicolon message. This
      --  distinction is of course a heuristic which does not always work,
      --  but in practice it is quite effective.

      --  Note: the one case in which we do not go through this circuit is
      --  when we have scanned a range attribute and want to return with
      --  Token pointing to the apostrophe. The apostrophe is not normally
      --  an expression terminator, and is not in Token_Class_Sterm, but
      --  in this special case we know that the expression is complete.

      if not Token_Is_At_Start_Of_Line
         and then Token not in Token_Class_Sterm
      then
         --  Normally the right error message is indeed that we expected a
         --  binary operator, but in the case of being between a right and left
         --  paren, e.g. in an aggregate, a more likely error is missing comma.

         if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
            T_Comma;

         --  And if we have a quote, we may have a bad attribute

         elsif At_Start_Of_Attribute then
            Error_Msg_SC ("prefix of attribute must be a name");

            if Ada_Version >= Ada_2012 then
               Error_Msg_SC ("\qualify expression to turn it into a name");
            end if;

         --  Normal case for binary operator expected message

         else
            Error_Msg_AP ("binary operator expected");
         end if;

         raise Error_Resync;

      else
         return Node1;
      end if;

   --  If any error occurs, then scan to next expression terminator symbol
   --  or comma, right paren or vertical bar at the outer (i.e. current) paren
   --  level. Expr_Form is set to indicate a normal simple expression.

   exception
      when Error_Resync =>
         Resync_Expression;
         Expr_Form := EF_Simple;
         return Error;
   end P_Simple_Expression;

   -----------------------------------------------
   -- 4.4  Simple Expression or Range Attribute --
   -----------------------------------------------

   --  SIMPLE_EXPRESSION ::=
   --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}

   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR

   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]

   --  Error recovery: cannot raise Error_Resync

   function P_Simple_Expression_Or_Range_Attribute return Node_Id is
      Sexpr     : Node_Id;
      Attr_Node : Node_Id;

   begin
      --  We don't just want to roar ahead and call P_Simple_Expression
      --  here, since we want to handle the case of a parenthesized range
      --  attribute cleanly.

      if Token = Tok_Left_Paren then
         declare
            Lptr       : constant Source_Ptr := Token_Ptr;
            Scan_State : Saved_Scan_State;

         begin
            Save_Scan_State (Scan_State);
            Scan; -- past left paren
            Sexpr := P_Simple_Expression;

            if Token = Tok_Apostrophe then
               Attr_Node := P_Range_Attribute_Reference (Sexpr);
               Expr_Form := EF_Range_Attr;

               if Token = Tok_Right_Paren then
                  Scan; -- scan past right paren if present
               end if;

               Error_Msg ("parentheses not allowed for range attribute", Lptr);

               return Attr_Node;
            end if;

            Restore_Scan_State (Scan_State);
         end;
      end if;

      --  Here after dealing with parenthesized range attribute

      Sexpr := P_Simple_Expression;

      if Token = Tok_Apostrophe then
         Attr_Node := P_Range_Attribute_Reference (Sexpr);
         Expr_Form := EF_Range_Attr;
         return Attr_Node;

      else
         return Sexpr;
      end if;
   end P_Simple_Expression_Or_Range_Attribute;

   ---------------
   -- 4.4  Term --
   ---------------

   --  TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}

   --  Error recovery: can raise Error_Resync

   function P_Term return Node_Id is
      Node1, Node2 : Node_Id;
      Tokptr       : Source_Ptr;

   begin
      Node1 := P_Factor;

      loop
         exit when Token not in Token_Class_Mulop;
         Tokptr := Token_Ptr;
         Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);

         if Style_Check and then not Debug_Flag_Dot_QQ then
            Style.Check_Binary_Operator;
         end if;

         Scan; -- past operator
         Set_Left_Opnd (Node2, Node1);
         Set_Right_Opnd (Node2, P_Factor);
         Node1 := Node2;
      end loop;

      return Node1;
   end P_Term;

   -----------------
   -- 4.4  Factor --
   -----------------

   --  FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY

   --  Error recovery: can raise Error_Resync

   function P_Factor return Node_Id is
      Node1 : Node_Id;
      Node2 : Node_Id;

   begin
      if Token = Tok_Abs then
         Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);

         if Style_Check then
            Style.Check_Abs_Not;
         end if;

         Scan; -- past ABS
         Set_Right_Opnd (Node1, P_Primary);
         return Node1;

      elsif Token = Tok_Not then
         Node1 := New_Op_Node (N_Op_Not, Token_Ptr);

         if Style_Check then
            Style.Check_Abs_Not;
         end if;

         Scan; -- past NOT
         Set_Right_Opnd (Node1, P_Primary);
         return Node1;

      else
         Node1 := P_Primary;

         if Token = Tok_Double_Asterisk then
            Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
            Scan; -- past **
            Set_Left_Opnd (Node2, Node1);
            Set_Right_Opnd (Node2, P_Primary);
            Check_Bad_Exp;
            return Node2;
         else
            return Node1;
         end if;
      end if;
   end P_Factor;

   ------------------
   -- 4.4  Primary --
   ------------------

   --  PRIMARY ::=
   --    NUMERIC_LITERAL  | null
   --  | STRING_LITERAL   | AGGREGATE
   --  | NAME             | QUALIFIED_EXPRESSION
   --  | ALLOCATOR        | (EXPRESSION) | QUANTIFIED_EXPRESSION

   --  Error recovery: can raise Error_Resync

   function P_Primary return Node_Id is
      Scan_State : Saved_Scan_State;
      Node1      : Node_Id;

      Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
      --  Remember if previous token is a left parenthesis. This is used to
      --  deal with checking whether IF/CASE/FOR expressions appearing as
      --  primaries require extra parenthesization.

   begin
      --  The loop runs more than once only if misplaced pragmas are found
      --  or if a misplaced unary minus is skipped.

      loop
         case Token is

            --  Name token can start a name, call or qualified expression, all
            --  of which are acceptable possibilities for primary. Note also
            --  that string literal is included in name (as operator symbol)
            --  and type conversion is included in name (as indexed component).

            when Tok_Char_Literal
               | Tok_Identifier
               | Tok_Operator_Symbol
            =>
               Node1 := P_Name;

               --  All done unless apostrophe follows

               if Token /= Tok_Apostrophe then
                  return Node1;

               --  Apostrophe following means that we have either just parsed
               --  the subtype mark of a qualified expression, or the prefix
               --  or a range attribute.

               else -- Token = Tok_Apostrophe
                  Save_Scan_State (Scan_State); -- at apostrophe
                  Scan; -- past apostrophe

                  --  If range attribute, then this is always an error, since
                  --  the only legitimate case (where the scanned expression is
                  --  a qualified simple name) is handled at the level of the
                  --  Simple_Expression processing. This case corresponds to a
                  --  usage such as 3 + A'Range, which is always illegal.

                  if Token = Tok_Range then
                     Restore_Scan_State (Scan_State); -- to apostrophe
                     Bad_Range_Attribute (Token_Ptr);
                     return Error;

                  --  If left paren, then we have a qualified expression.
                  --  Note that P_Name guarantees that in this case, where
                  --  Token = Tok_Apostrophe on return, the only two possible
                  --  tokens following the apostrophe are left paren and
                  --  RANGE, so we know we have a left paren here.

                  else -- Token = Tok_Left_Paren
                     return P_Qualified_Expression (Node1);

                  end if;
               end if;

            --  Numeric or string literal

            when Tok_Integer_Literal
               | Tok_Real_Literal
               | Tok_String_Literal
            =>
               Node1 := Token_Node;
               Scan; -- past number
               return Node1;

            --  Left paren, starts aggregate or parenthesized expression

            when Tok_Left_Paren =>
               declare
                  Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;

               begin
                  if Nkind (Expr) = N_Attribute_Reference
                    and then Attribute_Name (Expr) = Name_Range
                  then
                     Bad_Range_Attribute (Sloc (Expr));
                  end if;

                  return Expr;
               end;

            --  Allocator

            when Tok_New =>
               return P_Allocator;

            --  Null

            when Tok_Null =>
               Scan; -- past NULL
               return New_Node (N_Null, Prev_Token_Ptr);

            --  Pragma, not allowed here, so just skip past it

            when Tok_Pragma =>
               P_Pragmas_Misplaced;

            --  Deal with IF (possible unparenthesized if expression)

            when Tok_If =>

               --  If this looks like a real if, defined as an IF appearing at
               --  the start of a new line, then we consider we have a missing
               --  operand. If in Ada 2012 and the IF is not properly indented
               --  for a statement, we prefer to issue a message about an ill-
               --  parenthesized if expression.

               if Token_Is_At_Start_Of_Line
                 and then not
                   (Ada_Version >= Ada_2012
                     and then Style_Check_Indentation /= 0
                     and then Start_Column rem Style_Check_Indentation /= 0)
               then
                  Error_Msg_AP ("missing operand");
                  return Error;

               --  If this looks like an if expression, then treat it that way
               --  with an error message if not explicitly surrounded by
               --  parentheses.

               elsif Ada_Version >= Ada_2012 then
                  Node1 := P_If_Expression;

                  if not (Lparen and then Token = Tok_Right_Paren) then
                     Error_Msg
                       ("if expression must be parenthesized", Sloc (Node1));
                  end if;

                  return Node1;

               --  Otherwise treat as misused identifier

               else
                  return P_Identifier;
               end if;

            --  Deal with CASE (possible unparenthesized case expression)

            when Tok_Case =>

               --  If this looks like a real case, defined as a CASE appearing
               --  the start of a new line, then we consider we have a missing
               --  operand. If in Ada 2012 and the CASE is not properly
               --  indented for a statement, we prefer to issue a message about
               --  an ill-parenthesized case expression.

               if Token_Is_At_Start_Of_Line
                 and then not
                   (Ada_Version >= Ada_2012
                     and then Style_Check_Indentation /= 0
                     and then Start_Column rem Style_Check_Indentation /= 0)
               then
                  Error_Msg_AP ("missing operand");
                  return Error;

               --  If this looks like a case expression, then treat it that way
               --  with an error message if not within parentheses.

               elsif Ada_Version >= Ada_2012 then
                  Node1 := P_Case_Expression;

                  if not (Lparen and then Token = Tok_Right_Paren) then
                     Error_Msg
                       ("case expression must be parenthesized", Sloc (Node1));
                  end if;

                  return Node1;

               --  Otherwise treat as misused identifier

               else
                  return P_Identifier;
               end if;

            --  For [all | some]  indicates a quantified expression

            when Tok_For =>
               if Token_Is_At_Start_Of_Line then
                  Error_Msg_AP ("misplaced loop");
                  return Error;

               elsif Ada_Version >= Ada_2012 then
                  Save_Scan_State (Scan_State);
                  Scan;   --  past FOR

                  if Token = Tok_All or else Token = Tok_Some  then
                     Restore_Scan_State (Scan_State);  -- To FOR
                     Node1 := P_Quantified_Expression;

                     if not (Lparen and then Token = Tok_Right_Paren) then
                        Error_Msg
                          ("quantified expression must be parenthesized",
                           Sloc (Node1));
                     end if;
                  else
                     Restore_Scan_State (Scan_State);  -- To FOR
                     Node1 := P_Iterated_Component_Assoc_Or_Reduction;
                  end if;

                  return Node1;

               --  Otherwise treat as misused identifier

               else
                  return P_Identifier;
               end if;

            --  Minus may well be an improper attempt at a unary minus. Give
            --  a message, skip the minus and keep going.

            when Tok_Minus =>
               Error_Msg_SC ("parentheses required for unary minus");
               Scan; -- past minus

            when Tok_At_Sign =>  --  AI12-0125 : target_name
               if Ada_Version < Ada_2020 then
                  Error_Msg_SC ("target name is an Ada 2020 extension");
                  Error_Msg_SC ("\compile with -gnatX");
               end if;

               Node1 := P_Name;
               return Node1;

            --  Ada 2020: reduction expression parameter

            when Tok_Less =>
               Scan; -- past <

               Node1 :=
                 New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
               Set_Expression (Node1, P_Simple_Expression);

               Scan; -- past >
               return Node1;

            --  Anything else is illegal as the first token of a primary, but
            --  we test for some common errors, to improve error messages.

            when others =>
               if Is_Reserved_Identifier then
                  return P_Identifier;

               elsif Prev_Token = Tok_Comma then
                  Error_Msg_SP -- CODEFIX
                    ("|extra "","" ignored");
                  raise Error_Resync;

               else
                  Error_Msg_AP ("missing operand");
                  raise Error_Resync;
               end if;
         end case;
      end loop;
   end P_Primary;

   -------------------------------
   -- 4.4 Quantified_Expression --
   -------------------------------

   --  QUANTIFIED_EXPRESSION ::=
   --    for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
   --    for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE

   function P_Quantified_Expression return Node_Id is
      I_Spec : Node_Id;
      Node1  : Node_Id;

   begin
      Error_Msg_Ada_2012_Feature ("quantified expression", Token_Ptr);
      Scan;  --  past FOR
      Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);

      if Token = Tok_All then
         Set_All_Present (Node1);
      elsif Token /= Tok_Some then
         Error_Msg_AP ("missing quantifier");
         raise Error_Resync;
      end if;

      Scan; -- past ALL or SOME
      I_Spec := P_Loop_Parameter_Specification;

      if Nkind (I_Spec) = N_Loop_Parameter_Specification then
         Set_Loop_Parameter_Specification (Node1, I_Spec);
      else
         Set_Iterator_Specification (Node1, I_Spec);
      end if;

      if Token = Tok_Arrow then
         Scan;
         Set_Condition (Node1, P_Expression);
         return Node1;
      else
         Error_Msg_AP ("missing arrow");
         raise Error_Resync;
      end if;
   end P_Quantified_Expression;

   ---------------------------
   -- 4.5  Logical Operator --
   ---------------------------

   --  LOGICAL_OPERATOR  ::=  and | or | xor

   --  Note: AND THEN and OR ELSE are also treated as logical operators
   --  by the parser (even though they are not operators semantically)

   --  The value returned is the appropriate Node_Kind code for the operator
   --  On return, Token points to the token following the scanned operator.

   --  The caller has checked that the first token is a legitimate logical
   --  operator token (i.e. is either XOR, AND, OR).

   --  Error recovery: cannot raise Error_Resync

   function P_Logical_Operator return Node_Kind is
   begin
      if Token = Tok_And then
         if Style_Check then
            Style.Check_Binary_Operator;
         end if;

         Scan; -- past AND

         if Token = Tok_Then then
            Scan; -- past THEN
            return N_And_Then;
         else
            return N_Op_And;
         end if;

      elsif Token = Tok_Or then
         if Style_Check then
            Style.Check_Binary_Operator;
         end if;

         Scan; -- past OR

         if Token = Tok_Else then
            Scan; -- past ELSE
            return N_Or_Else;
         else
            return N_Op_Or;
         end if;

      else -- Token = Tok_Xor
         if Style_Check then
            Style.Check_Binary_Operator;
         end if;

         Scan; -- past XOR
         return N_Op_Xor;
      end if;
   end P_Logical_Operator;

   ------------------------------
   -- 4.5  Relational Operator --
   ------------------------------

   --  RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=

   --  The value returned is the appropriate Node_Kind code for the operator.
   --  On return, Token points to the operator token, NOT past it.

   --  The caller has checked that the first token is a legitimate relational
   --  operator token (i.e. is one of the operator tokens listed above).

   --  Error recovery: cannot raise Error_Resync

   function P_Relational_Operator return Node_Kind is
      Op_Kind : Node_Kind;
      Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
                     (Tok_Less          => N_Op_Lt,
                      Tok_Equal         => N_Op_Eq,
                      Tok_Greater       => N_Op_Gt,
                      Tok_Not_Equal     => N_Op_Ne,
                      Tok_Greater_Equal => N_Op_Ge,
                      Tok_Less_Equal    => N_Op_Le,
                      Tok_In            => N_In,
                      Tok_Not           => N_Not_In,
                      Tok_Box           => N_Op_Ne);

   begin
      if Token = Tok_Box then
         Error_Msg_SC -- CODEFIX
           ("|""'<'>"" should be ""/=""");
      end if;

      Op_Kind := Relop_Node (Token);

      if Style_Check then
         Style.Check_Binary_Operator;
      end if;

      Scan; -- past operator token

      --  Deal with NOT IN, if previous token was NOT, we must have IN now

      if Prev_Token = Tok_Not then

         --  Style check, for NOT IN, we require one space between NOT and IN

         if Style_Check and then Token = Tok_In then
            Style.Check_Not_In;
         end if;

         T_In;
      end if;

      return Op_Kind;
   end P_Relational_Operator;

   ---------------------------------
   -- 4.5  Binary Adding Operator --
   ---------------------------------

   --  BINARY_ADDING_OPERATOR ::= + | - | &

   --  The value returned is the appropriate Node_Kind code for the operator.
   --  On return, Token points to the operator token (NOT past it).

   --  The caller has checked that the first token is a legitimate adding
   --  operator token (i.e. is one of the operator tokens listed above).

   --  Error recovery: cannot raise Error_Resync

   function P_Binary_Adding_Operator return Node_Kind is
      Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
                     (Tok_Ampersand => N_Op_Concat,
                      Tok_Minus     => N_Op_Subtract,
                      Tok_Plus      => N_Op_Add);
   begin
      return Addop_Node (Token);
   end P_Binary_Adding_Operator;

   --------------------------------
   -- 4.5  Unary Adding Operator --
   --------------------------------

   --  UNARY_ADDING_OPERATOR ::= + | -

   --  The value returned is the appropriate Node_Kind code for the operator.
   --  On return, Token points to the operator token (NOT past it).

   --  The caller has checked that the first token is a legitimate adding
   --  operator token (i.e. is one of the operator tokens listed above).

   --  Error recovery: cannot raise Error_Resync

   function P_Unary_Adding_Operator return Node_Kind is
      Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
                     (Tok_Minus => N_Op_Minus,
                      Tok_Plus  => N_Op_Plus);
   begin
      return Addop_Node (Token);
   end P_Unary_Adding_Operator;

   -------------------------------
   -- 4.5  Multiplying Operator --
   -------------------------------

   --  MULTIPLYING_OPERATOR ::= * | / | mod | rem

   --  The value returned is the appropriate Node_Kind code for the operator.
   --  On return, Token points to the operator token (NOT past it).

   --  The caller has checked that the first token is a legitimate multiplying
   --  operator token (i.e. is one of the operator tokens listed above).

   --  Error recovery: cannot raise Error_Resync

   function P_Multiplying_Operator return Node_Kind is
      Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
        (Tok_Asterisk       => N_Op_Multiply,
         Tok_Mod            => N_Op_Mod,
         Tok_Rem            => N_Op_Rem,
         Tok_Slash          => N_Op_Divide);
   begin
      return Mulop_Node (Token);
   end P_Multiplying_Operator;

   --------------------------------------
   -- 4.5  Highest Precedence Operator --
   --------------------------------------

   --  Parsed by P_Factor (4.4)

   --  Note: this rule is not in fact used by the grammar at any point

   --------------------------
   -- 4.6  Type Conversion --
   --------------------------

   --  Parsed by P_Primary as a Name (4.1)

   -------------------------------
   -- 4.7  Qualified Expression --
   -------------------------------

   --  QUALIFIED_EXPRESSION ::=
   --    SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE

   --  The caller has scanned the name which is the Subtype_Mark parameter
   --  and scanned past the single quote following the subtype mark. The
   --  caller has not checked that this name is in fact appropriate for
   --  a subtype mark name (i.e. it is a selected component or identifier).

   --  Error_Recovery: cannot raise Error_Resync

   function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
      Qual_Node : Node_Id;
   begin
      Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
      Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
      Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
      return Qual_Node;
   end P_Qualified_Expression;

   --------------------
   -- 4.8  Allocator --
   --------------------

   --  ALLOCATOR ::=
   --      new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
   --    | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
   --
   --  SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)

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

   --  Error recovery: can raise Error_Resync

   function P_Allocator return Node_Id is
      Alloc_Node             : Node_Id;
      Type_Node              : Node_Id;
      Null_Exclusion_Present : Boolean;

   begin
      Alloc_Node := New_Node (N_Allocator, Token_Ptr);
      T_New;

      --  Scan subpool_specification if present (Ada 2012 (AI05-0111-3))

      --  Scan Null_Exclusion if present (Ada 2005 (AI-231))

      if Token = Tok_Left_Paren then
         Scan; -- past (
         Set_Subpool_Handle_Name (Alloc_Node, P_Name);
         T_Right_Paren;

         Error_Msg_Ada_2012_Feature
           ("|subpool specification",
            Sloc (Subpool_Handle_Name (Alloc_Node)));
      end if;

      Null_Exclusion_Present := P_Null_Exclusion;
      Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
      Type_Node := P_Subtype_Mark_Resync;

      if Token = Tok_Apostrophe then
         Scan; -- past apostrophe
         Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
      else
         Set_Expression
           (Alloc_Node,
            P_Subtype_Indication (Type_Node, Null_Exclusion_Present));

         --  AI05-0104: An explicit null exclusion is not allowed for an
         --  allocator without initialization. In previous versions of the
         --  language it just raises constraint error.

         if Ada_Version >= Ada_2012 and then Null_Exclusion_Present then
            Error_Msg_N
              ("an allocator with a subtype indication "
               & "cannot have a null exclusion", Alloc_Node);
         end if;
      end if;

      return Alloc_Node;
   end P_Allocator;

   -----------------------
   -- P_Case_Expression --
   -----------------------

   function P_Case_Expression return Node_Id is
      Loc        : constant Source_Ptr := Token_Ptr;
      Case_Node  : Node_Id;
      Save_State : Saved_Scan_State;

   begin
      Error_Msg_Ada_2012_Feature ("|case expression", Token_Ptr);
      Scan; -- past CASE
      Case_Node :=
        Make_Case_Expression (Loc,
          Expression   => P_Expression_No_Right_Paren,
          Alternatives => New_List);
      T_Is;

      --  We now have scanned out CASE expression IS, scan alternatives

      loop
         T_When;
         Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);

         --  Missing comma if WHEN (more alternatives present)

         if Token = Tok_When then
            T_Comma;

         --  A semicolon followed by "when" is probably meant to be a comma

         elsif Token = Tok_Semicolon then
            Save_Scan_State (Save_State);
            Scan; -- past the semicolon

            if Token /= Tok_When then
               Restore_Scan_State (Save_State);
               exit;
            end if;

            Error_Msg_SP -- CODEFIX
              ("|"";"" should be "",""");

         --  If comma/WHEN, skip comma and we have another alternative

         elsif Token = Tok_Comma then
            Save_Scan_State (Save_State);
            Scan; -- past comma

            if Token /= Tok_When then
               Restore_Scan_State (Save_State);
               exit;
            end if;

         --  If no comma or WHEN, definitely done

         else
            exit;
         end if;
      end loop;

      --  If we have an END CASE, diagnose as not needed

      if Token = Tok_End then
         Error_Msg_SC ("`END CASE` not allowed at end of case expression");
         Scan; -- past END

         if Token = Tok_Case then
            Scan; -- past CASE;
         end if;
      end if;

      --  Return the Case_Expression node

      return Case_Node;
   end P_Case_Expression;

   -----------------------------------
   -- P_Case_Expression_Alternative --
   -----------------------------------

   --  CASE_STATEMENT_ALTERNATIVE ::=
   --    when DISCRETE_CHOICE_LIST =>
   --      EXPRESSION

   --  The caller has checked that and scanned past the initial WHEN token
   --  Error recovery: can raise Error_Resync

   function P_Case_Expression_Alternative return Node_Id is
      Case_Alt_Node : Node_Id;
   begin
      Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
      Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
      TF_Arrow;
      Set_Expression (Case_Alt_Node, P_Expression);
      return Case_Alt_Node;
   end P_Case_Expression_Alternative;

   ---------------------------------------------
   -- P_Iterated_Component_Assoc_Or_Reduction --
   ---------------------------------------------

   --  ITERATED_COMPONENT_ASSOCIATION ::=
   --    for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION

   function P_Iterated_Component_Assoc_Or_Reduction return Node_Id is
      Expr : Node_Id;

      function OK_Reduction_Expression_Parameter (L : List_Id) return Boolean;
      --  Check that if a reduction_expression_Parameter appears, it is a
      --  single one.

      ---------------------------------------
      -- OK_Reduction_Expression_Parameter --
      ---------------------------------------

      function OK_Reduction_Expression_Parameter
        (L : List_Id) return Boolean
      is
         Actual : Node_Id;
         Num    : Int := 0;
         Seen   : Boolean;

      begin
         Seen := False;
         Actual := First (L);
         while Present (Actual) loop
            if Nkind (Actual) = N_Reduction_Expression_Parameter then
               if Seen then
                  Error_Msg_N ("only one reduction parameter allowed", Expr);
               else
                  Seen := True;
               end if;
            end if;

            Num := Num + 1;
            Next (Actual);
         end loop;

         if Seen and then Num > 2 then
            Error_Msg_N ("too many parameters in reduction function", Expr);
         end if;

         return Seen;
      end OK_Reduction_Expression_Parameter;

      --  Local variables

      Lparen     : constant Boolean := Prev_Token = Tok_Left_Paren;
      Assoc_Node : Node_Id;
      State      : Saved_Scan_State;

   --  Start of processing for P_Iterated_Component_Assoc_Or_Reduction

   begin
      Scan;  --  past FOR
      Assoc_Node :=
        New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);

      Save_Scan_State (State);
      Set_Defining_Identifier (Assoc_Node, P_Defining_Identifier);

      if Token = Tok_In then
         Scan; --  past in

         Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
         TF_Arrow;

         if Token = Tok_Less then
            Restore_Scan_State (State);
            return P_Reduction_Expression (Lparen);
         else
            Expr := P_Expression;
         end if;

         if Nkind (Expr) = N_Function_Call
           and then OK_Reduction_Expression_Parameter
                      (Parameter_Associations (Expr))
         then
            Restore_Scan_State (State);
            return P_Reduction_Expression (Lparen);

         elsif Nkind (Expr) in N_Op
           and then
             Nkind (Right_Opnd (Expr)) = N_Reduction_Expression_Parameter
         then
            return P_Reduction_Expression (Lparen);

         elsif Nkind (Expr) in N_Binary_Op
           and then
             Nkind (Left_Opnd (Expr)) = N_Reduction_Expression_Parameter
         then
            return P_Reduction_Expression (Lparen);

         elsif Nkind (Expr) = N_Indexed_Component
           and then OK_Reduction_Expression_Parameter (Expressions (Expr))
         then
            Restore_Scan_State (State);
            return P_Reduction_Expression (Lparen);
         end if;

         Set_Expression (Assoc_Node, Expr);
         if Ada_Version < Ada_2020 then
            Error_Msg_SC ("iterated component is an Ada 2020 extension");
            Error_Msg_SC ("\compile with -gnatX");
         end if;

         return Assoc_Node;

      elsif Token = Tok_Of then
         Restore_Scan_State (State);
         return P_Reduction_Expression (Lparen);

      else
         raise Error_Resync;
      end if;
   end P_Iterated_Component_Assoc_Or_Reduction;

   ----------------------------
   -- P_Reduction_Expression --
   ----------------------------

   function P_Reduction_Expression (Lparen : Boolean) return Node_Id is
      Expr           : Node_Id;
      I_Spec         : Node_Id;
      Left_Opnd      : Node_Id;
      Reduction_Node : Node_Id;

   begin
      Reduction_Node := New_Node (N_Reduction_Expression, Prev_Token_Ptr);

      I_Spec := P_Loop_Parameter_Specification;

      if Nkind (I_Spec) = N_Loop_Parameter_Specification then
         Set_Loop_Parameter_Specification (Reduction_Node, I_Spec);
      else
         Set_Iterator_Specification (Reduction_Node, I_Spec);
      end if;

      T_Arrow;
      if Token = Tok_Less and then False then
         Scan; -- past <

         Left_Opnd := New_Node (N_Reduction_Expression_Parameter, Token_Ptr);
         Set_Expression (Left_Opnd, P_Simple_Expression);

         Scan; -- past >

         if Token = Tok_Plus then
            Set_Expression
              (Reduction_Node, New_Op_Node (N_Op_Add, Token_Ptr));
         else
            Set_Expression
              (Reduction_Node, New_Op_Node (N_Op_Concat, Token_Ptr));
         end if;

         Scan; -- past operstor
         Set_Left_Opnd (Expression (Reduction_Node), Left_Opnd);
         Set_Right_Opnd (Expression (Reduction_Node), P_Primary);

      else
         Expr := P_Expression;
         Set_Expression (Reduction_Node, Expr);

         --  if Nkind (Expr) = N_Indexed_Component
         --    and then List_Length (Expressions (Expr)) /= 2
         --  then
         --     Error_Msg_N
         --        ("combiner function call must have two arguments", Expr);
         --  end if;
      end if;

      if Ada_Version < Ada_2020 then
         Error_Msg_SC ("Reduction_Expression is an Ada 2020 extension");
         Error_Msg_SC ("\compile with -gnatX");
      end if;

      if not (Lparen and then Token = Tok_Right_Paren) then
         Error_Msg
           ("reduction expression must be parenthesized",
            Sloc (Reduction_Node));
      else
         Scan; -- past ???
      end if;

      return Reduction_Node;
   end P_Reduction_Expression;

   ---------------------
   -- P_If_Expression --
   ---------------------

   --  IF_EXPRESSION ::=
   --    if CONDITION then DEPENDENT_EXPRESSION
   --                {elsif CONDITION then DEPENDENT_EXPRESSION}
   --                [else DEPENDENT_EXPRESSION]

   --  DEPENDENT_EXPRESSION ::= EXPRESSION

   function P_If_Expression return Node_Id is
      function P_If_Expression_Internal
        (Loc  : Source_Ptr;
         Cond : Node_Id) return Node_Id;
      --  This is the internal recursive routine that does all the work, it is
      --  recursive since it is used to process ELSIF parts, which internally
      --  are N_If_Expression nodes with the Is_Elsif flag set. The calling
      --  sequence is like the outer function except that the caller passes
      --  the conditional expression (scanned using P_Expression), and the
      --  scan pointer points just past this expression. Loc points to the
      --  IF or ELSIF token.

      ------------------------------
      -- P_If_Expression_Internal --
      ------------------------------

      function P_If_Expression_Internal
        (Loc  : Source_Ptr;
         Cond : Node_Id) return Node_Id
      is
         Exprs : constant List_Id    := New_List;
         Expr  : Node_Id;
         State : Saved_Scan_State;
         Eptr  : Source_Ptr;

      begin
         --  All cases except where we are at right paren

         if Token /= Tok_Right_Paren then
            TF_Then;
            Append_To (Exprs, P_Condition (Cond));
            Append_To (Exprs, P_Expression);

         --  Case of right paren (missing THEN phrase). Note that we know this
         --  is the IF case, since the caller dealt with this possibility in
         --  the ELSIF case.

         else
            Error_Msg_BC ("missing THEN phrase");
            Append_To (Exprs, P_Condition (Cond));
         end if;

         --  We now have scanned out IF expr THEN expr

         --  Check for common error of semicolon before the ELSE

         if Token = Tok_Semicolon then
            Save_Scan_State (State);
            Scan; -- past semicolon

            if Token = Tok_Else or else Token = Tok_Elsif then
               Error_Msg_SP -- CODEFIX
                 ("|extra "";"" ignored");

            else
               Restore_Scan_State (State);
            end if;
         end if;

         --  Scan out ELSIF sequence if present

         if Token = Tok_Elsif then
            Eptr := Token_Ptr;
            Scan; -- past ELSIF
            Expr := P_Expression;

            --  If we are at a right paren, we assume the ELSIF should be ELSE

            if Token = Tok_Right_Paren then
               Error_Msg ("ELSIF should be ELSE", Eptr);
               Append_To (Exprs, Expr);

            --  Otherwise we have an OK ELSIF

            else
               Expr := P_If_Expression_Internal (Eptr, Expr);
               Set_Is_Elsif (Expr);
               Append_To (Exprs, Expr);
            end if;

         --  Scan out ELSE phrase if present

         elsif Token = Tok_Else then

            --  Scan out ELSE expression

            Scan; -- Past ELSE
            Append_To (Exprs, P_Expression);

            --  Skip redundant ELSE parts

            while Token = Tok_Else loop
               Error_Msg_SC ("only one ELSE part is allowed");
               Scan; -- past ELSE
               Discard_Junk_Node (P_Expression);
            end loop;

         --  Two expression case (implied True, filled in during semantics)

         else
            null;
         end if;

         --  If we have an END IF, diagnose as not needed

         if Token = Tok_End then
            Error_Msg_SC ("`END IF` not allowed at end of if expression");
            Scan; -- past END

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

         --  Return the If_Expression node

         return Make_If_Expression (Loc, Expressions => Exprs);
      end P_If_Expression_Internal;

   --  Local variables

      Loc     : constant Source_Ptr := Token_Ptr;
      If_Expr : Node_Id;

   --  Start of processing for P_If_Expression

   begin
      Error_Msg_Ada_2012_Feature ("|if expression", Token_Ptr);
      Scan; -- past IF
      Inside_If_Expression := Inside_If_Expression + 1;
      If_Expr := P_If_Expression_Internal (Loc, P_Expression);
      Inside_If_Expression := Inside_If_Expression - 1;
      return If_Expr;
   end P_If_Expression;

   -----------------------
   -- P_Membership_Test --
   -----------------------

   --  MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
   --  MEMBERSHIP_CHOICE      ::= CHOICE_EXPRESSION | range | subtype_mark

   procedure P_Membership_Test (N : Node_Id) is
      Alt : constant Node_Id :=
              P_Range_Or_Subtype_Mark
                (Allow_Simple_Expression => (Ada_Version >= Ada_2012));

   begin
      --  Set case

      if Token = Tok_Vertical_Bar then
         Error_Msg_Ada_2012_Feature ("set notation", Token_Ptr);
         Set_Alternatives (N, New_List (Alt));
         Set_Right_Opnd   (N, Empty);

         --  Loop to accumulate alternatives

         while Token = Tok_Vertical_Bar loop
            Scan; -- past vertical bar
            Append_To
              (Alternatives (N),
               P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
         end loop;

      --  Not set case

      else
         Set_Right_Opnd   (N, Alt);
         Set_Alternatives (N, No_List);
      end if;
   end P_Membership_Test;

   ------------------------------------------
   -- P_Unparen_Cond_Case_Quant_Expression --
   ------------------------------------------

   function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
      Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;

      Result     : Node_Id;
      Scan_State : Saved_Scan_State;

   begin
      --  Case expression

      if Token = Tok_Case then
         Result := P_Case_Expression;

         if not (Lparen and then Token = Tok_Right_Paren) then
            Error_Msg_N ("case expression must be parenthesized!", Result);
         end if;

      --  If expression

      elsif Token = Tok_If then
         Result := P_If_Expression;

         if not (Lparen and then Token = Tok_Right_Paren) then
            Error_Msg_N ("if expression must be parenthesized!", Result);
         end if;

      --  Quantified expression or iterated component association

      elsif Token = Tok_For then

         Save_Scan_State (Scan_State);
         Scan;  --  past FOR

         if Token = Tok_All or else Token = Tok_Some then
            Restore_Scan_State (Scan_State);
            Result := P_Quantified_Expression;

            if not (Lparen and then Token = Tok_Right_Paren) then
               Error_Msg_N
                 ("quantified expression must be parenthesized!", Result);
            end if;

         else
            --  If no quantifier keyword, this is an iterated component in
            --  an aggregate.

            Restore_Scan_State (Scan_State);
            Result := P_Iterated_Component_Assoc_Or_Reduction;
         end if;

      --  No other possibility should exist (caller was supposed to check)

      else
         raise Program_Error;
      end if;

      --  Return expression (possibly after having given message)

      return Result;
   end P_Unparen_Cond_Case_Quant_Expression;

end Ch4;