From: Justin Squirek Date: Mon, 29 Mar 2021 14:06:55 +0000 (-0400) Subject: [Ada] INOX: prototype "when" constructs X-Git-Tag: upstream/12.2.0~7004 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=eba1160fddffe86acd62411b79e0147ea96bd3f2;p=platform%2Fupstream%2Fgcc.git [Ada] INOX: prototype "when" constructs gcc/ada/ * doc/gnat_rm/implementation_defined_pragmas.rst: Document new feature under pragma Extensions_Allowed. * gnat_rm.texi: Regenerate. * errout.adb, errout.ads (Error_Msg_GNAT_Extension): Created to issue errors when parsing extension only constructs. * exp_ch11.adb, exp_ch11.ads (Expand_N_Raise_When_Statement): Created to expand raise ... when constucts. * exp_ch5.adb, exp_ch5.ads (Expand_N_Goto_When_Statement): Created to expand goto ... when constructs. * exp_ch6.adb, exp_ch6.ads (Expand_N_Return_When_Statement): Created to expand return ... when constructs. * expander.adb (Expand): Add case entries for "when" constructs. * gen_il-gen-gen_nodes.adb, gen_il-types.ads: Add entries for "when" constructs. * par-ch11.adb (P_Raise_Statement): Add processing for raise ... when. * par-ch5.adb (Missing_Semicolon_On_Exit): Renamed to Missing_Semicolon_On_When and moved to par-util.adb. * par-ch6.adb (Get_Return_Kind): Renamed from Is_Simple and processing added for "return ... when" return kind. (Is_Simple): Renamed to Get_Return_Kind. (P_Return_Statement): Add case for return ... when variant of return statement. * par-util.adb, par.adb (Missing_Semicolon_On_When): Added to centeralize parsing of "when" keywords in the context of "when" constructs. * sem.adb (Analyze): Add case for "when" constructs. * sem_ch11.adb, sem_ch11.ads (Analyze_Raise_When_Statement): Created to analyze raise ... when constructs. * sem_ch5.adb, sem_ch5.ads (Analyzed_Goto_When_Statement): Created to analyze goto ... when constructs. * sem_ch6.adb, sem_ch6.ads (Analyze_Return_When_Statement): Created to analyze return ... when constructs. * sprint.adb (Sprint_Node_Actual): Add entries for new "when" nodes. --- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 6668dff..d86a2fd 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2214,6 +2214,23 @@ of GNAT specific extensions are recognized as follows: 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 diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index e4a0d4a..f643c8d 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -886,6 +886,19 @@ package body Errout is 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 -- ------------------------ diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1e34bc5..904c87d 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -942,6 +942,11 @@ package Errout is 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 diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 5981ff5..6058826 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1736,6 +1736,24 @@ package body Exp_Ch11 is 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 -- ---------------------------------- diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index d95a02c..057919b 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -34,6 +34,7 @@ package Exp_Ch11 is 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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 70866a8..0070706 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4176,6 +4176,23 @@ package body Exp_Ch5 is 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 -- --------------------------- diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads index fa47be1..75dd2cc 100644 --- a/gcc/ada/exp_ch5.ads +++ b/gcc/ada/exp_ch5.ads @@ -32,6 +32,7 @@ package Exp_Ch5 is 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); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 38d78b0..cd972e1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6064,6 +6064,23 @@ package body Exp_Ch6 is 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 -- -------------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 3b589be..07a88c5 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -32,6 +32,7 @@ package Exp_Ch6 is 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); diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 8243df2..e0483b7 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -274,6 +274,9 @@ package body Expander is 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); @@ -421,6 +424,9 @@ package body Expander is 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); @@ -442,6 +448,9 @@ package body Expander is 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); diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index c50caeb..26fc069 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1019,6 +1019,10 @@ begin -- Gen_IL.Gen.Gen_Nodes (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), @@ -1036,6 +1040,11 @@ begin -- Gen_IL.Gen.Gen_Nodes 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), @@ -1061,6 +1070,10 @@ begin -- Gen_IL.Gen.Gen_Nodes 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))); diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index 96231e9..482d01d 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -308,12 +308,15 @@ package Gen_IL.Types is 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, diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e7c97f3..79f8bb3 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3640,6 +3640,24 @@ This new aggregate syntax for arrays and containers is provided under -gnatX 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 diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 87751d1..8304c3e 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -233,6 +233,24 @@ package body Ch11 is 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; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index a702431..608ebd0 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1905,47 +1905,6 @@ package body Ch5 is 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 @@ -1975,7 +1934,7 @@ package body Ch5 is 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); @@ -2010,7 +1969,15 @@ package body Ch5 is 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; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 9d4f736..45a4214 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1874,18 +1874,20 @@ package body Ch6 is 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 @@ -1893,18 +1895,22 @@ package body Ch6 is 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 @@ -1917,7 +1923,6 @@ package body Ch6 is if Token = Tok_Semicolon then Scan; -- past ; - Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc); -- Nontrivial case @@ -1928,41 +1933,65 @@ package body Ch6 is -- 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; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 149b1a1..f4179b9 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -630,6 +630,35 @@ package body Util is 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 -- ------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 67339f1..649d2a0 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1351,6 +1351,18 @@ function Par (Configuration_Pragmas : Boolean) return List_Id 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. diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index a3deef5..783c94a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -298,6 +298,9 @@ package body Sem is 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); @@ -505,6 +508,9 @@ package body Sem is 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); @@ -526,6 +532,9 @@ package body Sem is 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); diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 13e37cf..5a2c6a6 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -662,6 +662,18 @@ package body Sem_Ch11 is 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 -- ----------------------------- diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads index 95a9a21..9b027d9 100644 --- a/gcc/ada/sem_ch11.ads +++ b/gcc/ada/sem_ch11.ads @@ -29,6 +29,7 @@ package Sem_Ch11 is 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); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 58cf6c2..3c98d73 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1825,6 +1825,18 @@ package body Sem_Ch5 is 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 -- -------------------------- diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 92fec23..c320665 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -33,6 +33,7 @@ package Sem_Ch5 is 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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05e74ef..d37f295 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2614,6 +2614,18 @@ package body Sem_Ch6 is 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 -- ------------------------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 05ef0c3..9579582 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -41,6 +41,7 @@ package Sem_Ch6 is 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); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 7fc7340..4467929 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2118,6 +2118,13 @@ package body Sprint is 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)); @@ -3069,6 +3076,19 @@ package body Sprint is 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 (" .. "); @@ -3142,6 +3162,13 @@ package body Sprint is 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]");