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