Daily bump.

[official-gcc.git] / gcc / ada / par-ch4.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              P A R . C H 4                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2012, 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_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)).

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

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

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

      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 erroneous 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.

            if Token = Tok_Left_Paren
              and then not
                Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
            then
               Set_Expressions (Name_Node, New_List);
               Scan; -- past left paren

               loop
                  declare
                     Expr : constant Node_Id := P_Expression_If_OK;

                  begin
                     if Token = Tok_Arrow then
                        Error_Msg_SC
                          ("named parameters not permitted for attributes");
                        Scan; -- past junk arrow

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

               T_Right_Paren;
            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.

         --      Note: conditional 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.

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

         Expr_Node := P_Expression_Or_Range_Attribute_If_OK;

         --  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 erroneous 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.

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

   --  Start of processing for P_Aggregate_Or_Paren_Expr

   begin
      Lparen_Sloc := Token_Ptr;
      T_Left_Paren;

      --  Conditional expression case

      if Token = Tok_If then
         Expr_Node := P_Conditional_Expression;
         T_Right_Paren;
         return Expr_Node;

      --  Case expression case

      elsif Token = Tok_Case then
         Expr_Node := P_Case_Expression;
         T_Right_Paren;
         return Expr_Node;

      --  Quantified expression case

      elsif Token = Tok_For then
         Expr_Node := P_Quantified_Expression;
         T_Right_Paren;
         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 aggregate cases first

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

         --  Deal with (NULL RECORD) case

         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;
         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 aggregate case

         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;

            Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
            Set_Ancestor_Part (Aggregate_Node, Expr_Node);
            Scan; -- past WITH

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

         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 case

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

      --  Others case

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

      --  Prepare to scan list of component associations

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

         elsif Token = Tok_Others then
            Expr_Node := Empty;

         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;
      Set_Expressions (Aggregate_Node, Expr_List);
      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 => <>

   --  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
      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);
            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

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

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

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

   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;
            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);
               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;
         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);
         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;

   begin
      --  The loop runs more than once only if misplaced pragmas are found

      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_Operator_Symbol | Tok_Identifier =>
               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 conditional 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 conditional 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 conditional expression, then treat it
               --  that way with an error message.

               elsif Ada_Version >= Ada_2012 then
                  Error_Msg_SC
                    ("conditional expression must be parenthesized");
                  return P_Conditional_Expression;

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

               elsif Ada_Version >= Ada_2012 then
                  Error_Msg_SC ("case expression must be parenthesized");
                  return P_Case_Expression;

               --  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
                  Error_Msg_SC ("quantified expression must be parenthesized");
                  return P_Quantified_Expression;

               else

               --  Otherwise treat as misused identifier

                  return P_Identifier;
               end if;

            --  Anything else is illegal as the first token of a primary, but
            --  we test for a reserved identifier so that it is treated nicely

            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
      if Ada_Version < Ada_2012 then
         Error_Msg_SC ("quantified expression is an Ada 2012 feature");
         Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
      end if;

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

      if Prev_Token = Tok_Not then
         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;

         if Ada_Version < Ada_2012 then
            Error_Msg_N
              ("|subpool specification is an Ada 2012 feature",
               Subpool_Handle_Name (Alloc_Node));
            Error_Msg_N
              ("\|unit must be compiled with -gnat2012 switch",
               Subpool_Handle_Name (Alloc_Node));
         end if;
      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));
      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
      if Ada_Version < Ada_2012 then
         Error_Msg_SC ("|case expression is an Ada 2012 feature");
         Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
      end if;

      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;

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

   function P_Conditional_Expression return Node_Id is
      Exprs : constant List_Id    := New_List;
      Loc   : constant Source_Ptr := Token_Ptr;
      Expr  : Node_Id;
      State : Saved_Scan_State;

   begin
      Inside_Conditional_Expression := Inside_Conditional_Expression + 1;

      if Token = Tok_If and then Ada_Version < Ada_2012 then
         Error_Msg_SC ("|conditional expression is an Ada 2012 feature");
         Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
      end if;

      Scan; -- past IF or ELSIF
      Append_To (Exprs, P_Condition);
      TF_Then;
      Append_To (Exprs, P_Expression);

      --  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
         Expr := P_Conditional_Expression;
         Set_Is_Elsif (Expr);
         Append_To (Exprs, Expr);

      --  Scan out ELSE phrase if present

      elsif Token = Tok_Else then

         --  Scan out ELSE expression

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

      --  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 conditional expression");
         Scan; -- past END

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

      Inside_Conditional_Expression := Inside_Conditional_Expression - 1;

      --  Return the Conditional_Expression node

      return
        Make_Conditional_Expression (Loc,
          Expressions => Exprs);
   end P_Conditional_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
         if Ada_Version < Ada_2012 then
            Error_Msg_SC ("set notation is an Ada 2012 feature");
            Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
         end if;

         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;

   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;

      --  Conditional expression

      elsif Token = Tok_If then
         Result := P_Conditional_Expression;

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

      --  Quantified expression

      elsif Token = Tok_For then
         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;

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