[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.

26 files changed, 343 insertions, 80 deletions

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..783c94aa 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]");