diff options
Diffstat (limited to 'gcc/ada/par-ch4.adb')
| -rw-r--r-- | gcc/ada/par-ch4.adb | 169 |
1 files changed, 151 insertions, 18 deletions
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2bb9d25..bb2063f 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -63,6 +63,7 @@ package body Ch4 is 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; @@ -366,7 +367,8 @@ package body Ch4 is 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 @@ -738,7 +740,8 @@ package body Ch4 is -- 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 @@ -1089,7 +1092,7 @@ package body Ch4 is 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 @@ -1164,6 +1167,13 @@ package body Ch4 is 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. @@ -1254,7 +1264,7 @@ package body Ch4 is 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; @@ -1332,7 +1342,7 @@ package body Ch4 is 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; @@ -1570,12 +1580,14 @@ package body Ch4 is 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; @@ -1672,11 +1684,13 @@ package body Ch4 is 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; @@ -2117,7 +2131,8 @@ package body Ch4 is 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; @@ -2339,10 +2354,10 @@ package body Ch4 is 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; @@ -2352,6 +2367,32 @@ package body Ch4 is 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 @@ -2360,7 +2401,8 @@ package body Ch4 is return P_Identifier; elsif Prev_Token = Tok_Comma then - Error_Msg_SP ("|extra "","" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); raise Error_Resync; else @@ -2458,7 +2500,8 @@ package body Ch4 is begin if Token = Tok_Box then - Error_Msg_SC ("|""'<'>"" should be ""/="""); + Error_Msg_SC -- CODEFIX + ("|""'<'>"" should be ""/="""); end if; Op_Kind := Relop_Node (Token); @@ -2620,6 +2663,95 @@ package body Ch4 is 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 -- ------------------------------ @@ -2652,7 +2784,8 @@ package body Ch4 is 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); @@ -2684,7 +2817,7 @@ package body Ch4 is -- 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 |