-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, 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. --
-- 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 Set_Op_Name (Node : Node_Id);
- -- Procedure to set name field (Chars) in operator node
-
-------------------------
-- Bad_Range_Attribute --
-------------------------
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;
- ------------------
- -- Set_Op_Name --
- ------------------
-
- procedure Set_Op_Name (Node : Node_Id) is
- type Name_Of_Type is array (N_Op) of Name_Id;
- 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,
- N_Op_Eq => Name_Op_Eq,
- N_Op_Ne => Name_Op_Ne,
- N_Op_Lt => Name_Op_Lt,
- N_Op_Le => Name_Op_Le,
- N_Op_Gt => Name_Op_Gt,
- N_Op_Ge => Name_Op_Ge,
- N_Op_Add => Name_Op_Add,
- N_Op_Subtract => Name_Op_Subtract,
- N_Op_Concat => Name_Op_Concat,
- N_Op_Multiply => Name_Op_Multiply,
- N_Op_Divide => Name_Op_Divide,
- N_Op_Mod => Name_Op_Mod,
- N_Op_Rem => Name_Op_Rem,
- N_Op_Expon => Name_Op_Expon,
- N_Op_Plus => Name_Op_Add,
- N_Op_Minus => Name_Op_Subtract,
- N_Op_Abs => Name_Op_Abs,
- N_Op_Not => Name_Op_Not,
-
- -- We don't really need these shift operators, since they never
- -- appear as operators in the source, but the path of least
- -- resistance is to put them in (the aggregate must be complete)
-
- N_Op_Rotate_Left => Name_Rotate_Left,
- N_Op_Rotate_Right => Name_Rotate_Right,
- N_Op_Shift_Left => Name_Shift_Left,
- N_Op_Shift_Right => Name_Shift_Right,
- N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
-
- begin
- if Nkind (Node) in N_Op then
- Set_Chars (Node, Name_Of (Nkind (Node)));
- end if;
- end Set_Op_Name;
-
--------------------------
-- 4.1 Name (also 6.4) --
--------------------------
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
Scan; -- past left paren
loop
- Discard_Junk_Node (P_Expression);
- exit when not Comma_Present;
+ Discard_Junk_Node (P_Expression_If_OK);
+ exit when not Comma_Present;
end loop;
T_Right_Paren;
Style.Check_Attribute_Name (False);
end if;
- Delete_Node (Token_Node);
-
-- Here for case of attribute designator is not an identifier
else
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
-- 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
-- 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;
-- 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.
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
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
return Aggregate_Node;
end if;
- Expr_Node := P_Expression_Or_Range_Attribute;
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
-- Extension aggregate case
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, 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)
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_Or_Range_Attribute;
+ Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
end if;
end loop;
if Token = Tok_Box then
-- Ada 2005(AI-287): The box notation is used to indicate the
- -- default initialization of limited aggregate components
+ -- default initialization of aggregate components
if Ada_Version < Ada_05 then
Error_Msg_SP
- ("limited aggregate is an Ada 2005 extension");
+ ("component association with '<'> is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
end if;
Node2 := Node1;
- Node1 := New_Node (Logical_Op, Op_Location);
+ Node1 := New_Op_Node (Logical_Op, Op_Location);
Set_Left_Opnd (Node1, Node2);
Set_Right_Opnd (Node1, P_Relation);
- Set_Op_Name (Node1);
exit when Token not in Token_Class_Logop;
end loop;
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 raise Error_Resync
+ -- 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;
Node2 := Node1;
- Node1 := New_Node (Logical_Op, Op_Location);
+ Node1 := New_Op_Node (Logical_Op, Op_Location);
Set_Left_Opnd (Node1, Node2);
Set_Right_Opnd (Node1, P_Relation);
- Set_Op_Name (Node1);
exit when Token not in Token_Class_Logop;
end loop;
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 --
-------------------
-- P_Relational_Operator also parses the IN and NOT IN operations.
Optok := Token_Ptr;
- Node2 := New_Node (P_Relational_Operator, Optok);
+ Node2 := New_Op_Node (P_Relational_Operator, Optok);
Set_Left_Opnd (Node2, Node1);
- Set_Op_Name (Node2);
-- 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;
- Node2 := New_Node (N_Op_Expon, Token_Ptr);
+ 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);
- Set_Op_Name (Node2);
Node1 := Node2;
end if;
loop
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;
+ 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);
- Set_Op_Name (Node2);
Node1 := Node2;
end loop;
loop
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;
+ 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);
- Set_Op_Name (Node2);
Node1 := Node2;
end loop;
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;
+ 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);
- Set_Op_Name (Node1);
else
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_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.
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
loop
exit when Token not in Token_Class_Mulop;
Tokptr := Token_Ptr;
- Node2 := New_Node (P_Multiplying_Operator, Tokptr);
+ Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
Scan; -- past operator
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Factor);
- Set_Op_Name (Node2);
Node1 := Node2;
end loop;
begin
if Token = Tok_Abs then
- Node1 := New_Node (N_Op_Abs, Token_Ptr);
- if Style_Check then Style.Check_Abs_Not; end if;
+ 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);
- Set_Op_Name (Node1);
return Node1;
elsif Token = Tok_Not then
- Node1 := New_Node (N_Op_Not, Token_Ptr);
- if Style_Check then Style.Check_Abs_Not; end if;
+ 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);
- Set_Op_Name (Node1);
return Node1;
else
Node1 := P_Primary;
if Token = Tok_Double_Asterisk then
- Node2 := New_Node (N_Op_Expon, Token_Ptr);
+ Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
Scan; -- past **
Set_Left_Opnd (Node2, Node1);
Set_Right_Opnd (Node2, P_Primary);
- Set_Op_Name (Node2);
return Node2;
else
return 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;
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;
OSDN Git Service
