-- --
-- B o d y --
-- --
--- $Revision: 1.91 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- 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_Body_Version => True,
+ Attribute_External_Tag => True,
+ Attribute_Img => True,
+ Attribute_Version => True,
+ Attribute_Base => True,
+ Attribute_Class => True,
+ Attribute_Stub_Type => 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 --
-----------------------
-- Called to place complaint about bad range attribute at the given
-- source location. Terminates by raising Error_Resync.
- function P_Range_Attribute_Reference
- (Prefix_Node : Node_Id)
- return Node_Id;
+ 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.
procedure Bad_Range_Attribute (Loc : Source_Ptr) is
begin
- Error_Msg ("range attribute cannot be used in expression", Loc);
+ Error_Msg ("range attribute cannot be used in expression!", Loc);
Resync_Expression;
end Bad_Range_Attribute;
procedure Set_Op_Name (Node : Node_Id) is
type Name_Of_Type is array (N_Op) of Name_Id;
- Name_Of : Name_Of_Type := Name_Of_Type'(
+ Name_Of : constant Name_Of_Type := Name_Of_Type'(
N_Op_And => Name_Op_And,
N_Op_Or => Name_Op_Or,
N_Op_Xor => Name_Op_Xor,
Attr_Name : Name_Id := No_Name; -- kill junk warning
begin
+ -- Case of not a name
+
if Token not in Token_Class_Name then
- Error_Msg_AP ("name expected");
- raise Error_Resync;
+
+ -- 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
begin
if Token_Is_At_Start_Of_Line then
Restore_Scan_State (Scan_State); -- to apostrophe
- Error_Msg_SC ("""''"" should be "";""");
+ Error_Msg_SC ("|""''"" should be "";""");
Token := Tok_Semicolon;
return True;
else
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;
Style.Check_Attribute_Name (False);
end if;
- Delete_Node (Token_Node);
-
-- Here for case of attribute designator is not an identifier
else
elsif Token = Tok_Access then
Attr_Name := Name_Access;
+ elsif Token = Tok_Mod and then Ada_Version = Ada_05 then
+ Attr_Name := Name_Mod;
+
elsif Apostrophe_Should_Be_Semicolon then
Expr_Form := EF_Name;
return Name_Node;
Set_Prefix (Name_Node, Prefix_Node);
Set_Attribute_Name (Name_Node, Attr_Name);
- -- Scan attribute arguments/designator
+ -- Scan attribute arguments/designator. We skip this if we know
+ -- that the attribute cannot have an argument.
- if Token = Tok_Left_Paren then
+ 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;
+ Expr : constant Node_Id := P_Expression_If_OK;
begin
if Token = Tok_Arrow then
-- (discrete_range)
- -- This is a slice. This case is handled in LP_State_Init.
+ -- This is a slice. This case is handled in LP_State_Init
-- (expression, expression, ..)
-- 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 occurence of identifier => (but
+ -- 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
-- Here we have an expression after all
- Expr_Node := P_Expression_Or_Range_Attribute;
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
-- Check cases of discrete range for a slice
elsif Token = Tok_Range then
if Expr_Form /= EF_Simple_Name then
- Error_Msg_SC ("subtype mark must precede RANGE");
+ Error_Msg_SC -- CODEFIX???
+ ("subtype mark must precede RANGE");
raise Error_Resync;
end if;
end if;
-- Comma present (and scanned out), test for identifier => case
- -- Test for identifer => case
+ -- Test for identifier => case
if Token = Tok_Identifier then
Save_Scan_State (Scan_State); -- at Id
-- Here we have an expression after all, so stay in this state
- Expr_Node := P_Expression;
+ Expr_Node := P_Expression_If_OK;
goto LP_State_Expr;
-- LP_State_Call corresponds to the situation in which at least
-- 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);
+ 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);
else
Prefix_Node := Name_Node;
- Name_Node :=
- New_Node (N_Function_Call, Sloc (Prefix_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;
("positional parameter association " &
"not allowed after named one");
- Expr_Node := P_Expression;
+ 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);
+ Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
end if;
-- We go back to scanning out expressions, so that we do not get
exception
when Error_Resync =>
return Error;
-
end P_Function_Name;
-- This function parses a restricted form of Names which are either
exception
when Error_Resync =>
return Error;
-
end P_Qualified_Simple_Name;
-- This procedure differs from P_Qualified_Simple_Name only in that it
Set_Selector_Name (Selector_Node, Designator_Node);
return Selector_Node;
end if;
-
end P_Qualified_Simple_Name_Resync;
----------------------
if Token = Tok_Left_Paren then
Scan; -- past left paren
- Set_Expressions (Attr_Node, New_List (P_Expression));
+ Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
T_Right_Paren;
end if;
end if;
end P_Aggregate;
- -------------------------------------------------
- -- 4.3 Aggregate or Parenthesized Expresssion --
- -------------------------------------------------
+ ------------------------------------------------
+ -- 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
-- POSITIONAL_ARRAY_AGGREGATE ::=
-- (EXPRESSION, EXPRESSION {, EXPRESSION})
-- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+ -- | (EXPRESSION {, EXPRESSION}, others => <>)
-- NAMED_ARRAY_AGGREGATE ::=
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
-- 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;
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;
+
-- 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
- if Token /= Tok_Others then
+ elsif Token /= Tok_Others then
Save_Scan_State (Scan_State); -- at start of expression
-- Deal with (NULL RECORD) case
end if;
end if;
- Expr_Node := P_Expression_Or_Range_Attribute;
+ -- 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.
+
+ if Ada_Version >= Ada_05 and then Token = Tok_Box then
+ Error_Msg_SC ("(Ada 2005) box notation only allowed with "
+ & "named notation");
+ Scan; -- past BOX
+ Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+ return Aggregate_Node;
+ end if;
+
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
-- Extension aggregate case
return Error;
end if;
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
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
- Bad_Range_Attribute (Sloc (Expr_Node));
- return Error;
+ Error_Msg
+ ("|parentheses not allowed for range attribute", Lparen_Sloc);
+ Scan; -- past right paren
+ return Expr_Node;
end if;
- -- Bump paren count of expression, note that if the paren count
- -- is already at the maximum, then we leave it alone. This will
- -- cause some failures in pathalogical conformance tests, which
- -- we do not shed a tear over!
+ -- Bump paren count of expression
if Expr_Node /= Error then
- if Paren_Count (Expr_Node) /= Paren_Count_Type'Last then
- Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
- end if;
+ Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
end if;
T_Right_Paren; -- past right paren (error message if none)
"extension aggregate");
raise Error_Resync;
+ -- A 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,
then
if Present (Assoc_List) then
Error_Msg_BC
- ("""=>"" expected (positional association cannot follow " &
+ ("""='>"" expected (positional association cannot follow " &
"named association)");
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
Expr_Node := Empty;
else
Save_Scan_State (Scan_State); -- at start of expression
- Expr_Node := P_Expression;
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
+
end if;
end loop;
-- RECORD_COMPONENT_ASSOCIATION ::=
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
+ -- | COMPONENT_CHOICE_LIST => <>
-- COMPONENT_CHOICE_LIST =>
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
-- 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
-- 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;
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
TF_Arrow;
- Set_Expression (Assoc_Node, P_Expression);
+
+ 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_05 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;
else
return Node1;
end if;
-
end P_Expression;
-- This function is identical to the normal P_Expression, except that it
+ -- also permits the appearence of a conditional expression without the
+ -- usual surrounding parentheses.
+
+ function P_Expression_If_OK return Node_Id is
+ begin
+ if Token = Tok_If then
+ return P_Conditional_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
- return No_Right_Paren (P_Expression);
+ Ignore (Tok_Right_Paren);
+ return Expr;
end P_Expression_No_Right_Paren;
----------------------------------------
end if;
end P_Expression_Or_Range_Attribute;
+ -- Version that allows a non-parenthesized conditional expression
+
+ function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
+ begin
+ if Token = Tok_If then
+ return P_Conditional_Expression;
+ else
+ return P_Expression_Or_Range_Attribute;
+ end if;
+ end P_Expression_Or_Range_Attribute_If_OK;
+
-------------------
-- 4.4 Relation --
-------------------
-- Case of IN or NOT IN
if Prev_Token = Tok_In then
- Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark);
+ P_Membership_Test (Node2);
-- Case of relational operator (= /= < <= > >=)
else
if Token = Tok_Double_Asterisk then
- if Style_Check then Style.Check_Exponentiation_Operator; end if;
+ if Style_Check then
+ Style.Check_Exponentiation_Operator;
+ end if;
+
Node2 := New_Node (N_Op_Expon, Token_Ptr);
Scan; -- past **
Set_Left_Opnd (Node2, Node1);
exit when Token not in Token_Class_Mulop;
Tokptr := Token_Ptr;
Node2 := New_Node (P_Multiplying_Operator, Tokptr);
- if Style_Check then Style.Check_Binary_Operator; end if;
+
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Factor);
exit when Token not in Token_Class_Binary_Addop;
Tokptr := Token_Ptr;
Node2 := New_Node (P_Binary_Adding_Operator, Tokptr);
- if Style_Check then Style.Check_Binary_Operator; end if;
+
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Term);
if Token in Token_Class_Unary_Addop then
Tokptr := Token_Ptr;
Node1 := New_Node (P_Unary_Adding_Operator, Tokptr);
- if Style_Check then Style.Check_Unary_Plus_Or_Minus; end if;
+
+ if Style_Check then
+ Style.Check_Unary_Plus_Or_Minus;
+ end if;
+
Scan; -- past operator
Set_Right_Opnd (Node1, P_Term);
Set_Op_Name (Node1);
Node1 := P_Term;
end if;
- -- Scan out sequence of terms separated by binary adding operators
+ -- 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
- loop
- exit when Token not in Token_Class_Binary_Addop;
- Tokptr := Token_Ptr;
- Node2 := New_Node (P_Binary_Adding_Operator, Tokptr);
- Scan; -- past operator
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Term);
- Set_Op_Name (Node2);
- Node1 := Node2;
- end loop;
+ 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_Node (P_Binary_Adding_Operator, Tokptr);
+ Scan; -- past operator
+ Set_Left_Opnd (Node2, Node1);
+ Node1 := P_Term;
+ Set_Right_Opnd (Node2, Node1);
+ Set_Op_Name (Node2);
+
+ -- 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.
if not Token_Is_At_Start_Of_Line
and then Token not in Token_Class_Sterm
then
- Error_Msg_AP ("binary operator expected");
+ -- 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;
Resync_Expression;
Expr_Form := EF_Simple;
return Error;
-
end P_Simple_Expression;
-----------------------------------------------
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
begin
if Token = Tok_Abs then
Node1 := New_Node (N_Op_Abs, Token_Ptr);
- if Style_Check then Style.Check_Abs_Not; end if;
+
+ if Style_Check then
+ Style.Check_Abs_Not;
+ end if;
+
Scan; -- past ABS
Set_Right_Opnd (Node1, P_Primary);
Set_Op_Name (Node1);
elsif Token = Tok_Not then
Node1 := New_Node (N_Op_Not, Token_Ptr);
- if Style_Check then Style.Check_Abs_Not; end if;
+
+ if Style_Check then
+ Style.Check_Abs_Not;
+ end if;
+
Scan; -- past NOT
Set_Right_Opnd (Node1, P_Primary);
Set_Op_Name (Node1);
-- Left paren, starts aggregate or parenthesized expression
when Tok_Left_Paren =>
- return P_Aggregate_Or_Paren_Expr;
+ 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_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 Token_Is_At_Start_Of_Line then
+ Error_Msg_AP ("missing operand");
+ return Error;
+
+ -- If this looks like a conditional expression, then treat it
+ -- that way with an error messasge.
+
+ elsif Extensions_Allowed then
+ Error_Msg_SC
+ ("conditional expression must be parenthesized");
+ return P_Conditional_Expression;
+
+ -- Otherwise treat as misused identifier
+
+ else
+ 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
return P_Identifier;
elsif Prev_Token = Tok_Comma then
- Error_Msg_SP ("extra "","" ignored");
+ Error_Msg_SP ("|extra "","" ignored");
raise Error_Resync;
else
function P_Logical_Operator return Node_Kind is
begin
if Token = Tok_And then
- if Style_Check then Style.Check_Binary_Operator; end if;
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past AND
if Token = Tok_Then then
end if;
elsif Token = Tok_Or then
- if Style_Check then Style.Check_Binary_Operator; end if;
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past OR
if Token = Tok_Else then
end if;
else -- Token = Tok_Xor
- if Style_Check then Style.Check_Binary_Operator; end if;
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past XOR
return N_Op_Xor;
end if;
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);
+ (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 ("""<>"" should be ""/=""");
+ Error_Msg_SC ("|""'<'>"" should be ""/=""");
end if;
Op_Kind := Relop_Node (Token);
- if Style_Check then Style.Check_Binary_Operator; end if;
+
+ if Style_Check then
+ Style.Check_Binary_Operator;
+ end if;
+
Scan; -- past operator token
if Prev_Token = Tok_Not then
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);
+ (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;
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);
+ (Tok_Minus => N_Op_Minus,
+ Tok_Plus => N_Op_Plus);
begin
return Addop_Node (Token);
end P_Unary_Adding_Operator;
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));
--------------------
-- ALLOCATOR ::=
- -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+ -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
-- 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;
+ Alloc_Node : Node_Id;
+ Type_Node : Node_Id;
+ Null_Exclusion_Present : Boolean;
begin
Alloc_Node := New_Node (N_Allocator, Token_Ptr);
T_New;
+
+ -- Scan Null_Exclusion if present (Ada 2005 (AI-231))
+
+ 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));
+ Set_Expression
+ (Alloc_Node,
+ P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
end if;
return Alloc_Node;
end P_Allocator;
+ ------------------------------
+ -- 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 not Extensions_Allowed then
+ Error_Msg_SC ("|conditional expression is an Ada extension");
+ Error_Msg_SC ("\|use -gnatX switch to compile this unit");
+ end if;
+
+ Scan; -- past IF or ELSIF
+ Append_To (Exprs, P_Expression_No_Right_Paren);
+ 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 ("|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 --
+ -----------------------
+
+ procedure P_Membership_Test (N : Node_Id) is
+ Alt : constant Node_Id :=
+ P_Range_Or_Subtype_Mark
+ (Allow_Simple_Expression => Extensions_Allowed);
+
+ begin
+ -- Set case
+
+ if Token = Tok_Vertical_Bar then
+ if not Extensions_Allowed then
+ Error_Msg_SC ("set notation is a language extension");
+ Error_Msg_SC ("\|use -gnatX switch to compile this unit");
+ 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;
+
end Ch4;