-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
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;
begin
if Token_Is_At_Start_Of_Line then
Restore_Scan_State (Scan_State); -- to apostrophe
- Error_Msg_SC ("|""''"" should be "";""");
+ Error_Msg_SC -- CODEFIX???
+ ("|""''"" should be "";""");
Token := Tok_Semicolon;
return True;
else
-- a possible fix.
if Nkind (Expr_Node) = N_Op_Eq then
- Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
+ Error_Msg_N -- CODEFIX???
+ ("\maybe `='>` was intended", Expr_Node);
end if;
-- We go back to scanning out expressions, so that we do not get
and then
Nkind (Aggr_Node) /= N_Extension_Aggregate
then
- Error_Msg
+ Error_Msg -- CODEFIX???
("aggregate may not have single positional component", Aggr_Sloc);
return Error;
else
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;
+
-- 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.
if Nkind (Expr_Node) = N_Attribute_Reference
and then Attribute_Name (Expr_Node) = Name_Range
then
- Error_Msg
+ Error_Msg -- CODEFIX???
("|parentheses not allowed for range attribute", Lparen_Sloc);
Scan; -- past right paren
return Expr_Node;
or else Token = Tok_Semicolon
then
if Present (Assoc_List) then
- Error_Msg_BC
+ Error_Msg_BC -- CODEFIX
("""='>"" expected (positional association cannot follow " &
"named association)");
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.
+ -- also permits the appearence of a case of conditional expression without
+ -- the usual surrounding parentheses.
function P_Expression_If_OK return Node_Id is
begin
- if Token = Tok_If then
+ if Token = Tok_Case then
+ return P_Case_Expression;
+ elsif Token = Tok_If then
return P_Conditional_Expression;
else
return P_Expression;
end if;
end P_Expression_Or_Range_Attribute;
- -- Version that allows a non-parenthesized conditional expression
+ -- Version that allows a non-parenthesized case or conditional expression
function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
begin
- if Token = Tok_If then
+ if Token = Tok_Case then
+ return P_Case_Expression;
+ elsif Token = Tok_If then
return P_Conditional_Expression;
else
return P_Expression_Or_Range_Attribute;
Scan; -- scan past right paren if present
end if;
- Error_Msg ("parentheses not allowed for range attribute", Lptr);
+ Error_Msg -- CODEFIX???
+ ("parentheses not allowed for range attribute", Lptr);
return Attr_Node;
end if;
return Error;
-- If this looks like a conditional expression, then treat it
- -- that way with an error messasge.
+ -- that way with an error message.
elsif Extensions_Allowed then
- Error_Msg_SC
+ Error_Msg_SC -- CODEFIX???
("conditional expression must be parenthesized");
return P_Conditional_Expression;
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 Token_Is_At_Start_Of_Line 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 Extensions_Allowed then
+ Error_Msg_SC -- CODEFIX???
+ ("case expression must be parenthesized");
+ return P_Case_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 -- CODEFIX
+ ("|extra "","" ignored");
raise Error_Resync;
else
begin
if Token = Tok_Box then
- Error_Msg_SC ("|""'<'>"" should be ""/=""");
+ Error_Msg_SC -- CODEFIX
+ ("|""'<'>"" should be ""/=""");
end if;
Op_Kind := Relop_Node (Token);
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 not Extensions_Allowed then
+ Error_Msg_SC ("|case expression is an Ada extension");
+ Error_Msg_SC ("\|use -gnatX switch to compile this unit");
+ 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 -- CODEFIX???
+ ("`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 --
------------------------------
Scan; -- past semicolon
if Token = Tok_Else or else Token = Tok_Elsif then
- Error_Msg_SP ("|extra "";"" ignored");
+ Error_Msg_SP -- CODEFIX
+ ("|extra "";"" ignored");
else
Restore_Scan_State (State);
-- If we have an END IF, diagnose as not needed
if Token = Tok_End then
- Error_Msg_SC
+ Error_Msg_SC -- CODEFIX???
("`END IF` not allowed at end of conditional expression");
Scan; -- past END
OSDN Git Service
