public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-1693] [Ada] INOX: prototype "when" constructs
@ 2021-06-21 11:06 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-06-21 11:06 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:eba1160fddffe86acd62411b79e0147ea96bd3f2
commit r12-1693-geba1160fddffe86acd62411b79e0147ea96bd3f2
Author: Justin Squirek <squirek@adacore.com>
Date: Mon Mar 29 10:06:55 2021 -0400
[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:
---
.../doc/gnat_rm/implementation_defined_pragmas.rst | 17 ++++
gcc/ada/errout.adb | 13 +++
gcc/ada/errout.ads | 5 +
gcc/ada/exp_ch11.adb | 18 ++++
gcc/ada/exp_ch11.ads | 1 +
gcc/ada/exp_ch5.adb | 17 ++++
gcc/ada/exp_ch5.ads | 1 +
gcc/ada/exp_ch6.adb | 17 ++++
gcc/ada/exp_ch6.ads | 1 +
gcc/ada/expander.adb | 9 ++
gcc/ada/gen_il-gen-gen_nodes.adb | 13 +++
gcc/ada/gen_il-types.ads | 3 +
gcc/ada/gnat_rm.texi | 18 ++++
gcc/ada/par-ch11.adb | 18 ++++
gcc/ada/par-ch5.adb | 53 ++---------
gcc/ada/par-ch6.adb | 103 +++++++++++++--------
gcc/ada/par-util.adb | 29 ++++++
gcc/ada/par.adb | 12 +++
gcc/ada/sem.adb | 9 ++
gcc/ada/sem_ch11.adb | 12 +++
gcc/ada/sem_ch11.ads | 1 +
gcc/ada/sem_ch5.adb | 12 +++
gcc/ada/sem_ch5.ads | 1 +
gcc/ada/sem_ch6.adb | 12 +++
gcc/ada/sem_ch6.ads | 1 +
gcc/ada/sprint.adb | 27 ++++++
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 6668dffcc0c..d86a2fd75cd 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 e4a0d4a0d6e..f643c8da6fc 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 1e34bc52b33..904c87d2914 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 5981ff5fa65..605882600cd 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 d95a02cf24b..057919bbc52 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 70866a893f5..00707060f1c 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 fa47be11854..75dd2cc808e 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 38d78b08ef2..cd972e1a9c2 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 3b589be72d4..07a88c55c3c 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 8243df251f4..e0483b7d029 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 c50caeb8eab..26fc069271c 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 96231e9312f..482d01d1159 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 e7c97f3071e..79f8bb354ee 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -3639,6 +3639,24 @@ now under -gnatX to confirm and potentially refine its usage and syntax.
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)
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index 87751d19870..8304c3e8779 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 a7024317b55..608ebd030e4 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 9d4f736a61f..45a421420cb 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 149b1a1f223..f4179b9ece7 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 67339f1ca3f..649d2a08dc0 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 a3deef54772..783c94aa53e 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 13e37cf1f13..5a2c6a6828b 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 95a9a2167e4..9b027d9295b 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 58cf6c22fda..3c98d738297 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 92fec23de86..c32066513ac 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 05e74efab90..d37f295d917 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 05ef0c33a4e..9579582763b 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 7fc73409d1a..446792911dd 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]");
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-06-21 11:06 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-06-21 11:06 [gcc r12-1693] [Ada] INOX: prototype "when" constructs Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).