This new aggregate syntax for arrays and containers is provided under -gnatX
to experiment and confirm this new language syntax.
+* Additional ``when`` constructs
+
+ In addition to the ``exit when CONDITION`` control structure, several
+ additional constructs are allowed following this format. Including
+ ``return when CONDITION``, ``goto when CONDITION``, and
+ ``raise [with EXCEPTION_MESSAGE] when CONDITION.``
+
+ Some examples:
+
+ .. code-block:: ada
+
+ return Result when Variable > 10;
+
+ raise Program_Error with "Element is null" when Element = null;
+
+ goto End_Of_Subprogram when Variable = -1;
+
* Casing on composite values (aka pattern matching)
The selector for a case statement may be of a composite type, subject to
Last => Last_Sloc (Lst)));
end Error_Msg_FE;
+ ------------------------------
+ -- Error_Msg_GNAT_Extension --
+ ------------------------------
+
+ procedure Error_Msg_GNAT_Extension (Extension : String) is
+ Loc : constant Source_Ptr := Token_Ptr;
+ begin
+ if not Extensions_Allowed then
+ Error_Msg (Extension & " is a 'G'N'A'T specific extension", Loc);
+ Error_Msg ("\unit must be compiled with -gnatX switch", Loc);
+ end if;
+ end Error_Msg_GNAT_Extension;
+
------------------------
-- Error_Msg_Internal --
------------------------
procedure Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr);
-- Analogous to Error_Msg_Ada_2012_Feature, for Ada 2022
+ procedure Error_Msg_GNAT_Extension (Extension : String);
+ -- If not operating with extensions allowed, posts errors complaining
+ -- that Extension is only supported when the -gnatX switch is enabled,
+ -- with appropriate suggestions to fix it.
+
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
Analyze (N);
end Expand_N_Raise_Statement;
+ -----------------------------------
+ -- Expand_N_Raise_When_Statement --
+ -----------------------------------
+
+ procedure Expand_N_Raise_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Raise_Statement (Loc,
+ Name => Name (N),
+ Expression => Expression (N)))));
+
+ Analyze (N);
+ end Expand_N_Raise_When_Statement;
+
----------------------------------
-- Expand_N_Raise_Storage_Error --
----------------------------------
procedure Expand_N_Raise_Expression (N : Node_Id);
procedure Expand_N_Raise_Program_Error (N : Node_Id);
procedure Expand_N_Raise_Statement (N : Node_Id);
+ procedure Expand_N_Raise_When_Statement (N : Node_Id);
procedure Expand_N_Raise_Storage_Error (N : Node_Id);
-- Data structures for gathering information to build exception tables
Analyze (N);
end Expand_Formal_Container_Element_Loop;
+ ----------------------------------
+ -- Expand_N_Goto_When_Statement --
+ ----------------------------------
+
+ procedure Expand_N_Goto_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Goto_Statement (Loc,
+ Name => Name (N)))));
+
+ Analyze (N);
+ end Expand_N_Goto_When_Statement;
+
---------------------------
-- Expand_N_If_Statement --
---------------------------
procedure Expand_N_Block_Statement (N : Node_Id);
procedure Expand_N_Case_Statement (N : Node_Id);
procedure Expand_N_Exit_Statement (N : Node_Id);
+ procedure Expand_N_Goto_When_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id);
procedure Expand_N_Loop_Statement (N : Node_Id);
Expand_Call (N);
end Expand_N_Procedure_Call_Statement;
+ ------------------------------------
+ -- Expand_N_Return_When_Statement --
+ ------------------------------------
+
+ procedure Expand_N_Return_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expression (N)))));
+
+ Analyze (N);
+ end Expand_N_Return_When_Statement;
+
--------------------------------------
-- Expand_N_Simple_Return_Statement --
--------------------------------------
procedure Expand_N_Extended_Return_Statement (N : Node_Id);
procedure Expand_N_Function_Call (N : Node_Id);
procedure Expand_N_Procedure_Call_Statement (N : Node_Id);
+ procedure Expand_N_Return_When_Statement (N : Node_Id);
procedure Expand_N_Simple_Return_Statement (N : Node_Id);
procedure Expand_N_Subprogram_Body (N : Node_Id);
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id);
when N_Generic_Instantiation =>
Expand_N_Generic_Instantiation (N);
+ when N_Goto_When_Statement =>
+ Expand_N_Goto_When_Statement (N);
+
when N_Handled_Sequence_Of_Statements =>
Expand_N_Handled_Sequence_Of_Statements (N);
when N_Raise_Statement =>
Expand_N_Raise_Statement (N);
+ when N_Raise_When_Statement =>
+ Expand_N_Raise_When_Statement (N);
+
when N_Raise_Constraint_Error =>
Expand_N_Raise_Constraint_Error (N);
when N_Requeue_Statement =>
Expand_N_Requeue_Statement (N);
+ when N_Return_When_Statement =>
+ Expand_N_Return_When_Statement (N);
+
when N_Simple_Return_Statement =>
Expand_N_Simple_Return_Statement (N);
(Sy (Name, Node_Id, Default_Empty),
Sm (Exception_Junk, Flag)));
+ Cc (N_Goto_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
Cc (N_Loop_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Identifier, Node_Id, Default_Empty),
Sy (Iteration_Scheme, Node_Id, Default_Empty),
Sy (Expression, Node_Id, Default_Empty),
Sm (From_At_End, Flag)));
+ Cc (N_Raise_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
Cc (N_Requeue_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Name, Node_Id, Default_Empty),
Sy (Abort_Present, Flag),
Sm (Return_Statement_Entity, Node_Id),
Sm (Storage_Pool, Node_Id)));
+ Cc (N_Return_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
Cc (N_Selective_Accept, N_Statement_Other_Than_Procedure_Call,
(Sy (Select_Alternatives, List_Id),
Sy (Else_Statements, List_Id, Default_No_List)));
N_Entry_Call_Statement,
N_Free_Statement,
N_Goto_Statement,
+ N_Goto_When_Statement,
N_Loop_Statement,
N_Null_Statement,
N_Raise_Statement,
+ N_Raise_When_Statement,
N_Requeue_Statement,
N_Simple_Return_Statement,
N_Extended_Return_Statement,
+ N_Return_When_Statement,
N_Selective_Accept,
N_Timed_Entry_Call,
N_Exit_Statement,
to experiment and confirm this new language syntax.
@item
+Additional @code{when} constructs
+
+In addition to the @code{exit when CONDITION} control structure, several
+additional constructs are allowed following this format. Including
+@code{return when CONDITION}, @code{goto when CONDITION}, and
+@code{raise [with EXCEPTION_MESSAGE] when CONDITION.}
+
+Some examples:
+
+@example
+return Result when Variable > 10;
+
+raise Program_Error with "Element is null" when Element = null;
+
+goto End_Of_Subprogram when Variable = -1;
+@end example
+
+@item
Casing on composite values (aka pattern matching)
The selector for a case statement may be of a composite type, subject to
Set_Expression (Raise_Node, P_Expression);
end if;
+ if Token = Tok_When then
+ Error_Msg_GNAT_Extension ("raise when statement");
+
+ Mutate_Nkind (Raise_Node, N_Raise_When_Statement);
+
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Scan; -- past WHEN
+ Set_Condition (Raise_Node, P_Expression_No_Right_Paren);
+
+ -- Allow IF instead of WHEN, giving error message
+
+ elsif Token = Tok_If then
+ T_When;
+ Scan; -- past IF used in place of WHEN
+ Set_Condition (Raise_Node, P_Expression_No_Right_Paren);
+ end if;
+ end if;
+
TF_Semicolon;
return Raise_Node;
end P_Raise_Statement;
function P_Exit_Statement return Node_Id is
Exit_Node : Node_Id;
- function Missing_Semicolon_On_Exit return Boolean;
- -- This function deals with the following specialized situation
- --
- -- when 'x' =>
- -- exit [identifier]
- -- when 'y' =>
- --
- -- This looks like a messed up EXIT WHEN, when in fact the problem
- -- is a missing semicolon. It is called with Token pointing to the
- -- WHEN token, and returns True if a semicolon is missing before
- -- the WHEN as in the above example.
-
- -------------------------------
- -- Missing_Semicolon_On_Exit --
- -------------------------------
-
- function Missing_Semicolon_On_Exit return Boolean is
- State : Saved_Scan_State;
-
- begin
- if not Token_Is_At_Start_Of_Line then
- return False;
-
- elsif Scopes (Scope.Last).Etyp /= E_Case then
- return False;
-
- else
- Save_Scan_State (State);
- Scan; -- past WHEN
- Scan; -- past token after WHEN
-
- if Token = Tok_Arrow then
- Restore_Scan_State (State);
- return True;
- else
- Restore_Scan_State (State);
- return False;
- end if;
- end if;
- end Missing_Semicolon_On_Exit;
-
-- Start of processing for P_Exit_Statement
begin
end loop Check_No_Exit_Name;
end if;
- if Token = Tok_When and then not Missing_Semicolon_On_Exit then
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
Scan; -- past WHEN
Set_Condition (Exit_Node, P_Condition);
Scan; -- past GOTO (or TO)
Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
Append_Elmt (Goto_Node, Goto_List);
- No_Constraint;
+
+ if Token = Tok_When then
+ Error_Msg_GNAT_Extension ("goto when statement");
+
+ Scan; -- past WHEN
+ Mutate_Nkind (Goto_Node, N_Goto_When_Statement);
+ Set_Condition (Goto_Node, P_Expression_No_Right_Paren);
+ end if;
+
TF_Semicolon;
return Goto_Node;
end P_Goto_Statement;
function P_Return_Statement return Node_Id is
-- The caller has checked that the initial token is RETURN
- function Is_Simple return Boolean;
+ type Return_Kind is (Simple_Return, Extended_Return, Return_When);
+
+ function Get_Return_Kind return Return_Kind;
-- Scan state is just after RETURN (and is left that way). Determine
-- whether this is a simple or extended return statement by looking
-- ahead for "identifier :", which implies extended.
- ---------------
- -- Is_Simple --
- ---------------
+ ---------------------
+ -- Get_Return_Kind --
+ ---------------------
- function Is_Simple return Boolean is
+ function Get_Return_Kind return Return_Kind is
Scan_State : Saved_Scan_State;
- Result : Boolean := True;
+ Result : Return_Kind := Simple_Return;
begin
if Token = Tok_Identifier then
Scan; -- past identifier
if Token = Tok_Colon then
- Result := False; -- It's an extended_return_statement.
+ Result := Extended_Return; -- It's an extended_return_statement
+ elsif Token = Tok_When then
+ Error_Msg_GNAT_Extension ("return when statement");
+
+ Result := Return_When;
end if;
Restore_Scan_State (Scan_State); -- to identifier
end if;
return Result;
- end Is_Simple;
+ end Get_Return_Kind;
Ret_Sloc : constant Source_Ptr := Token_Ptr;
Ret_Strt : constant Column_Number := Start_Column;
- Ret_Node : Node_Id;
+ Ret_Node : Node_Id := New_Node (N_Simple_Return_Statement, Ret_Sloc);
Decl : Node_Id;
-- Start of processing for P_Return_Statement
if Token = Tok_Semicolon then
Scan; -- past ;
- Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc);
-- Nontrivial case
-- expression terminator since in that case the best error
-- message is probably that we have a missing semicolon.
- if Is_Simple then
- Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc);
+ case Get_Return_Kind is
+ -- Return_when_statement (Experimental only)
- if Token not in Token_Class_Eterm then
- Set_Expression (Ret_Node, P_Expression_No_Right_Paren);
- end if;
+ when Return_When =>
+ Ret_Node := New_Node (N_Return_When_Statement, Ret_Sloc);
- -- Extended_return_statement (Ada 2005 only -- AI-318):
+ if Token not in Token_Class_Eterm then
+ Set_Expression (Ret_Node, P_Expression_No_Right_Paren);
+ end if;
- else
- Error_Msg_Ada_2005_Extension ("extended return statement");
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Scan; -- past WHEN
+ Set_Condition (Ret_Node, P_Condition);
- Ret_Node := New_Node (N_Extended_Return_Statement, Ret_Sloc);
- Decl := P_Return_Object_Declaration;
- Set_Return_Object_Declarations (Ret_Node, New_List (Decl));
+ -- Allow IF instead of WHEN, giving error message
- if Token = Tok_With then
- P_Aspect_Specifications (Decl, False);
- end if;
+ elsif Token = Tok_If then
+ T_When;
+ Scan; -- past IF used in place of WHEN
+ Set_Condition (Ret_Node, P_Expression_No_Right_Paren);
+ end if;
- if Token = Tok_Do then
- Push_Scope_Stack;
- Scopes (Scope.Last).Ecol := Ret_Strt;
- Scopes (Scope.Last).Etyp := E_Return;
- Scopes (Scope.Last).Labl := Error;
- Scopes (Scope.Last).Sloc := Ret_Sloc;
+ -- Simple_return_statement
- Scan; -- past DO
- Set_Handled_Statement_Sequence
- (Ret_Node, P_Handled_Sequence_Of_Statements);
- End_Statements;
+ when Simple_Return =>
+ Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc);
- -- Do we need to handle Error_Resync here???
- end if;
- end if;
+ if Token not in Token_Class_Eterm then
+ Set_Expression (Ret_Node, P_Expression_No_Right_Paren);
+ end if;
+
+ -- Extended_return_statement (Ada 2005 only -- AI-318):
+
+ when Extended_Return =>
+ Error_Msg_Ada_2005_Extension ("extended return statement");
+
+ Ret_Node := New_Node (N_Extended_Return_Statement, Ret_Sloc);
+ Decl := P_Return_Object_Declaration;
+ Set_Return_Object_Declarations (Ret_Node, New_List (Decl));
+
+ if Token = Tok_With then
+ P_Aspect_Specifications (Decl, False);
+ end if;
+
+ if Token = Tok_Do then
+ Push_Scope_Stack;
+ Scopes (Scope.Last).Ecol := Ret_Strt;
+ Scopes (Scope.Last).Etyp := E_Return;
+ Scopes (Scope.Last).Labl := Error;
+ Scopes (Scope.Last).Sloc := Ret_Sloc;
+
+ Scan; -- past DO
+ Set_Handled_Statement_Sequence
+ (Ret_Node, P_Handled_Sequence_Of_Statements);
+ End_Statements;
+
+ -- Do we need to handle Error_Resync here???
+ end if;
+ end case;
TF_Semicolon;
end if;
Scan;
end Merge_Identifier;
+ -------------------------------
+ -- Missing_Semicolon_On_When --
+ -------------------------------
+
+ function Missing_Semicolon_On_When return Boolean is
+ State : Saved_Scan_State;
+
+ begin
+ if not Token_Is_At_Start_Of_Line then
+ return False;
+
+ elsif Scopes (Scope.Last).Etyp /= E_Case then
+ return False;
+
+ else
+ Save_Scan_State (State);
+ Scan; -- past WHEN
+ Scan; -- past token after WHEN
+
+ if Token = Tok_Arrow then
+ Restore_Scan_State (State);
+ return True;
+ else
+ Restore_Scan_State (State);
+ return False;
+ end if;
+ end if;
+ end Missing_Semicolon_On_When;
+
-------------------
-- Next_Token_Is --
-------------------
-- conditions are met, an error message is issued, and the merge is
-- carried out, modifying the Chars field of Prev.
+ function Missing_Semicolon_On_When return Boolean;
+ -- This function deals with the following specialized situations
+ --
+ -- when 'x' =>
+ -- exit/return [identifier]
+ -- when 'y' =>
+ --
+ -- This looks like a messed up EXIT WHEN or RETURN WHEN, when in fact
+ -- the problem is a missing semicolon. It is called with Token pointing
+ -- to the WHEN token, and returns True if a semicolon is missing before
+ -- the WHEN as in the above example.
+
function Next_Token_Is (Tok : Token_Type) return Boolean;
-- Looks at token after current one and returns True if the token type
-- matches Tok. The scan is unconditionally restored on return.
when N_Goto_Statement =>
Analyze_Goto_Statement (N);
+ when N_Goto_When_Statement =>
+ Analyze_Goto_When_Statement (N);
+
when N_Handled_Sequence_Of_Statements =>
Analyze_Handled_Statements (N);
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
+ when N_Raise_When_Statement =>
+ Analyze_Raise_When_Statement (N);
+
when N_Raise_xxx_Error =>
Analyze_Raise_xxx_Error (N);
when N_Requeue_Statement =>
Analyze_Requeue (N);
+ when N_Return_When_Statement =>
+ Analyze_Return_When_Statement (N);
+
when N_Simple_Return_Statement =>
Analyze_Simple_Return_Statement (N);
Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Raise_Statement;
+ ----------------------------------
+ -- Analyze_Raise_When_Statement --
+ ----------------------------------
+
+ procedure Analyze_Raise_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Raise_When_Statement;
+
-----------------------------
-- Analyze_Raise_xxx_Error --
-----------------------------
procedure Analyze_Handled_Statements (N : Node_Id);
procedure Analyze_Raise_Expression (N : Node_Id);
procedure Analyze_Raise_Statement (N : Node_Id);
+ procedure Analyze_Raise_When_Statement (N : Node_Id);
procedure Analyze_Raise_xxx_Error (N : Node_Id);
procedure Analyze_Exception_Handlers (L : List_Id);
raise Program_Error;
end Analyze_Goto_Statement;
+ ---------------------------------
+ -- Analyze_Goto_When_Statement --
+ ---------------------------------
+
+ procedure Analyze_Goto_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Goto_When_Statement;
+
--------------------------
-- Analyze_If_Statement --
--------------------------
procedure Analyze_Compound_Statement (N : Node_Id);
procedure Analyze_Exit_Statement (N : Node_Id);
procedure Analyze_Goto_Statement (N : Node_Id);
+ procedure Analyze_Goto_When_Statement (N : Node_Id);
procedure Analyze_If_Statement (N : Node_Id);
procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
procedure Analyze_Iterator_Specification (N : Node_Id);
Analyze_Dimension (N);
end Analyze_Return_Statement;
+ -----------------------------------
+ -- Analyze_Return_When_Statement --
+ -----------------------------------
+
+ procedure Analyze_Return_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Return_When_Statement;
+
-------------------------------------
-- Analyze_Simple_Return_Statement --
-------------------------------------
procedure Analyze_Operator_Symbol (N : Node_Id);
procedure Analyze_Parameter_Association (N : Node_Id);
procedure Analyze_Procedure_Call (N : Node_Id);
+ procedure Analyze_Return_When_Statement (N : Node_Id);
procedure Analyze_Simple_Return_Statement (N : Node_Id);
procedure Analyze_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Subprogram_Body (N : Node_Id);
Write_Indent;
end if;
+ when N_Goto_When_Statement =>
+ Write_Indent_Str_Sloc ("goto ");
+ Sprint_Node (Name (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+ Write_Char (';');
+
when N_Handled_Sequence_Of_Statements =>
Set_Debug_Sloc;
Sprint_Indented_List (Statements (Node));
Write_Char (';');
+ when N_Raise_When_Statement =>
+ Write_Indent_Str_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str_With_Col_Check_Sloc (" with ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char (';');
+
when N_Range =>
Sprint_Node (Low_Bound (Node));
Write_Str_Sloc (" .. ");
Write_Char (';');
+ when N_Return_When_Statement =>
+ Write_Indent_Str_Sloc ("return ");
+ Sprint_Node (Expression (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+ Write_Char (';');
+
when N_SCIL_Dispatch_Table_Tag_Init =>
Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
projects / platform / upstream / gcc.git / commitdiff