From: Ronan Desplanques <desplanq...@adacore.com>
This extension adds "continue" as a nonreserved keyword, and this is the
first occurrence of a nonreserved keyword in GNAT, which causes this
patch to add unusual overload resolution code.
New node kinds are introduced, but since they are entirely transformed
into existing constructs during expansion, back ends that don't turn off
expansion do not need to be updated.
gcc/ada/ChangeLog:
* doc/gnat_rm/gnat_language_extensions.rst: Document new extension.
* gen_il-fields.ads (Opt_Field_Enum): Add new fields.
* gen_il-types.ads (N_Loop_Flow_Statement, N_Continue_Statement): New
node kinds.
* gen_il-gen-gen_nodes.adb (N_Loop_Flow_Statement): New abstract node
kind.
(N_Continue_Statement): New node kind.
(N_Exit_Statement): Reparent below N_Loop_Flow_Statement.
* sinfo.ads (N_Continue_Statement): Add description.
* sinfo-utils.ads (Loop_Flow_Keyword): New function.
* sinfo-utils.adb (Loop_Flow_Keyword): New function.
* gen_il-gen-gen_entities.adb (E_Loop): Add new field.
* einfo.ads (Continue_Mark): Document new field.
* sprint.adb (Sprint_Node_Actual): Update for new node kind.
* snames.ads-tmpl: Add new keyword.
* par-ch5.adb (P_Continue_Statement, Parse_Loop_Flow_Statement): New
functions.
(P_Sequence_Of_Statements): Handle continue statements.
(P_Exit_Statement): Use Parse_Loop_Flow_Statement.
* sem.adb (Analyze): Handle new node kind.
* sem_ch5.adb (Analyze_Loop_Flow_Statement): New function.
(Analyze_Continue_Statement): New procedure.
(Analyze_Exit_Statement): Use new Analyze_Loop_Flow_Statement function.
* sem_ch5.ads (Analyze_Continue_Statement): New procedure.
* expander.adb (Expand): Handle new node kind.
* exp_ch5.ads (Expand_N_Continue_Statement): New procedure.
* exp_ch5.adb (Expand_Loop_Flow_Statement): New procedure.
(Expand_N_Continue_Statement): New procedure.
(Expand_N_Exit_Statement): Use new Expand_Loop_Flow_Statement
procedure.
(Build_Formal_Container_Iteration): Always reuse original loop entity.
* gnat_rm.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
.../doc/gnat_rm/gnat_language_extensions.rst | 16 +
gcc/ada/einfo.ads | 8 +
gcc/ada/exp_ch5.adb | 117 ++++++-
gcc/ada/exp_ch5.ads | 1 +
gcc/ada/expander.adb | 3 +
gcc/ada/gen_il-fields.ads | 2 +
gcc/ada/gen_il-gen-gen_entities.adb | 3 +-
gcc/ada/gen_il-gen-gen_nodes.adb | 15 +-
gcc/ada/gen_il-types.ads | 2 +
gcc/ada/gnat_rm.texi | 84 +++--
gcc/ada/par-ch5.adb | 105 ++++--
gcc/ada/sem.adb | 3 +
gcc/ada/sem_ch5.adb | 322 +++++++++++++-----
gcc/ada/sem_ch5.ads | 1 +
gcc/ada/sinfo-utils.adb | 13 +
gcc/ada/sinfo-utils.ads | 4 +
gcc/ada/sinfo.ads | 26 ++
gcc/ada/snames.ads-tmpl | 1 +
gcc/ada/sprint.adb | 4 +-
19 files changed, 551 insertions(+), 179 deletions(-)
diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
index bdc4e675488..f31317942c2 100644
--- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
+++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst
@@ -1777,3 +1777,19 @@ If an exception is raised in the finally part, it cannot
be caught by the ``exce
Abort/ATC (asynchronous transfer of control) cannot interrupt a finally block,
nor prevent its
execution, that is the finally block must be executed in full even if the
containing task is
aborted, or if the control is transferred out of the block.
+
+Continue statement
+------------------
+
+The ``continue`` keyword makes it possible to stop execution of a loop
iteration
+and continue with the next one. A continue statement has the same syntax
+(except "exit" is replaced with "continue"), static semantics, and legality
+rules as an exit statement. The difference is in the dynamic semantics: where
an
+exit statement would cause a transfer of control that completes the (implicitly
+or explicitly) specified loop_statement, a continue statement would instead
+cause a transfer of control that completes only the current iteration of that
+loop_statement, like a goto statement targeting a label following the last
+statement in the sequence of statements of the specified loop_statement.
+
+Note that ``continue`` is a keyword but it is not a reserved word. This is a
+configuration that does not exist in standard Ada.
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d8958d62855..ba79fe4aa86 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -716,6 +716,14 @@ package Einfo is
-- bodies. Set if the entity contains any ignored Ghost code in the form
-- of declaration, procedure call, assignment statement or pragma.
+-- Continue_Mark
+-- Defined in loop entities. It points to the loop's statement after
+-- which the label for continue statements must be inserted if one is
+-- needed. This is not always the last statement in the loop's list; it
+-- can notably be followed by assignment statements generated by
+-- expansion of iterator specifications, which continue statements must
+-- not jump past.
+
-- Contract
-- Defined in constant, entry, entry family, operator, [generic] package,
-- package body, protected unit, [generic] subprogram, subprogram body,
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index f1a7610bf28..f46fb4779a6 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -190,6 +190,9 @@ package body Exp_Ch5 is
-- specification and Container is either the Container (for OF) or the
-- iterator (for IN).
+ procedure Expand_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id);
+ -- Common processing for expansion of "loop flow" statements
+
procedure Expand_Predicated_Loop (N : Node_Id);
-- Expand for loop over predicated subtype
@@ -280,14 +283,11 @@ package body Exp_Ch5 is
Statements => Stats,
End_Label => Empty);
- -- If the contruct has a specified loop name, preserve it in the new
- -- loop, for possible use in exit statements.
+ -- Preserve the construct's loop name in the new loop, for possible use
+ -- in exit statements.
- if Present (Identifier (N))
- and then Comes_From_Source (Identifier (N))
- then
- Set_Identifier (New_Loop, Identifier (N));
- end if;
+ pragma Assert (Present (Identifier (N)));
+ Set_Identifier (New_Loop, Identifier (N));
end Build_Formal_Container_Iteration;
------------------------------
@@ -4425,16 +4425,98 @@ package body Exp_Ch5 is
end;
end Expand_N_Case_Statement;
+ ---------------------------------
+ -- Expand_N_Continue_Statement --
+ ---------------------------------
+
+ procedure Expand_N_Continue_Statement (N : Node_Id) is
+ X : constant Node_Id := Call_Or_Target_Loop (N);
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Label : E_Label_Id;
+ begin
+ if No (X) then
+ return;
+ end if;
+
+ if Nkind (X) = N_Procedure_Call_Statement then
+ Replace (N, X);
+ Analyze (N);
+ return;
+ end if;
+
+ Expand_Loop_Flow_Statement (N);
+
+ declare
+ L : constant E_Loop_Id := Call_Or_Target_Loop (N);
+ M : constant Node_Id := Continue_Mark (L);
+ A : constant Node_Id := Next (M);
+ begin
+ if not (Present (A) and then Nkind (A) = N_Label) then
+ -- This is the first continue statement that is expanded for this
+ -- loop; we set up the label that the goto statement will target.
+ declare
+ P : constant Node_Id := Atree.Node_Parent (L);
+
+ Decl_List : constant List_Id :=
+ (if Nkind (P) = N_Implicit_Label_Declaration
+ then List_Containing (P)
+ else Declarations (Parent (Parent (P))));
+
+ Label_Entity : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (Chars (L), 'C'));
+ Label_Id : constant N_Identifier_Id :=
+ Make_Identifier (Loc, Chars (Label_Entity));
+ Label_Node : constant N_Label_Id :=
+ Make_Label (Loc, Label_Id);
+ Label_Decl : constant N_Implicit_Label_Declaration_Id :=
+ Make_Implicit_Label_Declaration
+ (Loc, Label_Entity, Label_Node);
+ begin
+ Mutate_Ekind (Label_Entity, E_Label);
+ Set_Etype (Label_Entity, Standard_Void_Type);
+
+ Set_Entity (Label_Id, Label_Entity);
+ Set_Etype (Label_Id, Standard_Void_Type);
+
+ Insert_After (Node => Label_Node, After => M);
+
+ Append (Node => Label_Decl, To => Decl_List);
+
+ Label := Label_Entity;
+ end;
+ else
+ -- Some other continue statement for this loop was expanded
+ -- already, so we can reuse the label that is already set up.
+ Label := Entity (Identifier (A));
+ end if;
+ end;
+
+ declare
+ C : constant Opt_N_Subexpr_Id := Condition (N);
+ Goto_St : constant N_Goto_Statement_Id :=
+ Make_Goto_Statement (Loc, New_Occurrence_Of (Label, Loc));
+
+ New_St : constant Node_Id :=
+ (if Present (C)
+ then Make_If_Statement (Sloc (N), C, New_List (Goto_St))
+ else Goto_St);
+ begin
+ Set_Parent (New_St, Parent (N));
+ Replace (N, New_St);
+ end;
+
+ end Expand_N_Continue_Statement;
+
-----------------------------
-- Expand_N_Exit_Statement --
-----------------------------
- -- The only processing required is to deal with a possible C/Fortran
- -- boolean value used as the condition for the exit statement.
-
procedure Expand_N_Exit_Statement (N : Node_Id) is
begin
- Adjust_Condition (Condition (N));
+ Expand_Loop_Flow_Statement (N);
end Expand_N_Exit_Statement;
----------------------------------
@@ -5756,7 +5838,6 @@ package body Exp_Ch5 is
Loc : constant Source_Ptr := Sloc (N);
Scheme : constant Node_Id := Iteration_Scheme (N);
Stmt : Node_Id;
-
begin
-- Delete null loop
@@ -6043,6 +6124,18 @@ package body Exp_Ch5 is
Process_Statements_For_Controlled_Objects (Stmt);
end Expand_N_Loop_Statement;
+ --------------------------------
+ -- Expand_Loop_Flow_Statement --
+ --------------------------------
+
+ -- The only processing required is to deal with a possible C/Fortran
+ -- boolean value used as the condition for the statement.
+
+ procedure Expand_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id) is
+ begin
+ Adjust_Condition (Condition (N));
+ end Expand_Loop_Flow_Statement;
+
----------------------------
-- Expand_Predicated_Loop --
----------------------------
diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads
index efde755c08f..e75c1282233 100644
--- a/gcc/ada/exp_ch5.ads
+++ b/gcc/ada/exp_ch5.ads
@@ -31,6 +31,7 @@ package Exp_Ch5 is
procedure Expand_N_Assignment_Statement (N : Node_Id);
procedure Expand_N_Block_Statement (N : Node_Id);
procedure Expand_N_Case_Statement (N : Node_Id);
+ procedure Expand_N_Continue_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);
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index 8cec8217214..3d7b0d77f11 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -230,6 +230,9 @@ package body Expander is
when N_Conditional_Entry_Call =>
Expand_N_Conditional_Entry_Call (N);
+ when N_Continue_Statement =>
+ Expand_N_Continue_Statement (N);
+
when N_Delay_Relative_Statement =>
Expand_N_Delay_Relative_Statement (N);
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 9871035416d..2d16e12805b 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -401,6 +401,7 @@ package Gen_IL.Fields is
Synchronized_Present,
Tagged_Present,
Target,
+ Call_Or_Target_Loop,
Target_Type,
Task_Definition,
Task_Present,
@@ -473,6 +474,7 @@ package Gen_IL.Fields is
Component_Type,
Constructor_List,
Constructor_Name,
+ Continue_Mark,
Contract,
Contract_Wrapper,
Corresponding_Concurrent_Type,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index 3c0ded9f72e..8cbed8a5989 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -1223,7 +1223,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Cc (E_Loop, Entity_Kind,
-- A loop identifier, created by an explicit or implicit label on a
-- loop statement.
- (Sm (First_Entity, Node_Id),
+ (Sm (Continue_Mark, Node_Id),
+ Sm (First_Entity, Node_Id),
Sm (First_Exit_Statement, Node_Id),
Sm (Has_Exit, Flag),
Sm (Has_Loop_Entry_Attributes, Flag),
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index e50a488e90a..debc66b0fcd 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -967,6 +967,16 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Is_Null_Loop, Flag),
Sy (Suppress_Loop_Warnings, Flag)));
+ Ab (N_Loop_Flow_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Continue_Statement, N_Loop_Flow_Statement,
+ (Sm (Call_Or_Target_Loop, Node_Id)));
+
+ Cc (N_Exit_Statement, N_Loop_Flow_Statement,
+ (Sm (Next_Exit_Statement, Node_Id)));
+
Cc (N_Null_Statement, N_Statement_Other_Than_Procedure_Call,
(Sm (Next_Rep_Item, Node_Id)));
@@ -1012,11 +1022,6 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Entry_Call_Alternative, Node_Id),
Sy (Delay_Alternative, Node_Id)));
- Cc (N_Exit_Statement, N_Statement_Other_Than_Procedure_Call,
- (Sy (Name, Node_Id, Default_Empty),
- Sy (Condition, Node_Id, Default_Empty),
- Sm (Next_Exit_Statement, Node_Id)));
-
Cc (N_If_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Condition, Node_Id, Default_Empty),
Sy (Then_Statements, List_Id),
diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads
index 6e0ab5b5da2..c3a97558f70 100644
--- a/gcc/ada/gen_il-types.ads
+++ b/gcc/ada/gen_il-types.ads
@@ -103,6 +103,7 @@ package Gen_IL.Types is
N_Is_Range,
N_Multiplying_Operator,
N_Later_Decl_Item,
+ N_Loop_Flow_Statement,
N_Membership_Test,
N_Numeric_Or_String_Literal,
N_Op,
@@ -328,6 +329,7 @@ package Gen_IL.Types is
N_Code_Statement,
N_Compound_Statement,
N_Conditional_Entry_Call,
+ N_Continue_Statement,
N_Delay_Relative_Statement,
N_Delay_Until_Statement,
N_Entry_Call_Statement,
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 3683f91fb33..f45ea7c0ae8 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -929,6 +929,7 @@ Experimental Language Extensions
* Inference of Dependent Types in Generic Instantiations::
* External_Initialization Aspect::
* Finally construct::
+* Continue statement::
Storage Model
@@ -31202,6 +31203,7 @@ Features activated via @code{-gnatX0} or
* Inference of Dependent Types in Generic Instantiations::
* External_Initialization Aspect::
* Finally construct::
+* Continue statement::
@end menu
@@ -32497,7 +32499,7 @@ The maximum size of loaded files is limited to 2@w{^31}
bytes.
@end quotation
@end cartouche
-@node Finally construct,,External_Initialization Aspect,Experimental Language
Extensions
+@node Finally construct,Continue statement,External_Initialization
Aspect,Experimental Language Extensions
@anchor{gnat_rm/gnat_language_extensions finally-construct}@anchor{46d}
@subsection Finally construct
@@ -32554,8 +32556,26 @@ Abort/ATC (asynchronous transfer of control) cannot
interrupt a finally block, n
execution, that is the finally block must be executed in full even if the
containing task is
aborted, or if the control is transferred out of the block.
+@node Continue statement,,Finally construct,Experimental Language Extensions
+@anchor{gnat_rm/gnat_language_extensions continue-statement}@anchor{471}
+@subsection Continue statement
+
+
+The @code{continue} keyword makes it possible to stop execution of a loop
iteration
+and continue with the next one. A continue statement has the same syntax
+(except “exit” is replaced with “continue”), static semantics, and legality
+rules as an exit statement. The difference is in the dynamic semantics: where
an
+exit statement would cause a transfer of control that completes the (implicitly
+or explicitly) specified loop_statement, a continue statement would instead
+cause a transfer of control that completes only the current iteration of that
+loop_statement, like a goto statement targeting a label following the last
+statement in the sequence of statements of the specified loop_statement.
+
+Note that @code{continue} is a keyword but it is not a reserved word. This is a
+configuration that does not exist in standard Ada.
+
@node Security Hardening Features,Obsolescent Features,GNAT language
extensions,Top
-@anchor{gnat_rm/security_hardening_features
doc}@anchor{471}@anchor{gnat_rm/security_hardening_features
id1}@anchor{472}@anchor{gnat_rm/security_hardening_features
security-hardening-features}@anchor{15}
+@anchor{gnat_rm/security_hardening_features
doc}@anchor{472}@anchor{gnat_rm/security_hardening_features
id1}@anchor{473}@anchor{gnat_rm/security_hardening_features
security-hardening-features}@anchor{15}
@chapter Security Hardening Features
@@ -32577,7 +32597,7 @@ change.
@end menu
@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{473}
+@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{474}
@section Register Scrubbing
@@ -32613,7 +32633,7 @@ programming languages, see @cite{Using the GNU Compiler
Collection (GCC)}.
@c Stack Scrubbing:
@node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security
Hardening Features
-@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{474}
+@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{475}
@section Stack Scrubbing
@@ -32757,7 +32777,7 @@ Bar_Callable_Ptr.
@c Hardened Conditionals:
@node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security
Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{475}
+@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{476}
@section Hardened Conditionals
@@ -32847,7 +32867,7 @@ be used with other programming languages supported by
GCC.
@c Hardened Booleans:
@node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security
Hardening Features
-@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{476}
+@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{477}
@section Hardened Booleans
@@ -32908,7 +32928,7 @@ and more details on that attribute, see @cite{Using the
GNU Compiler Collection
@c Control Flow Redundancy:
@node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features
-@anchor{gnat_rm/security_hardening_features
control-flow-redundancy}@anchor{477}
+@anchor{gnat_rm/security_hardening_features
control-flow-redundancy}@anchor{478}
@section Control Flow Redundancy
@@ -33076,7 +33096,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}.
These options
can be used with other programming languages supported by GCC.
@node Obsolescent Features,Compatibility and Porting Guide,Security Hardening
Features,Top
-@anchor{gnat_rm/obsolescent_features
doc}@anchor{478}@anchor{gnat_rm/obsolescent_features
id1}@anchor{479}@anchor{gnat_rm/obsolescent_features
obsolescent-features}@anchor{16}
+@anchor{gnat_rm/obsolescent_features
doc}@anchor{479}@anchor{gnat_rm/obsolescent_features
id1}@anchor{47a}@anchor{gnat_rm/obsolescent_features
obsolescent-features}@anchor{16}
@chapter Obsolescent Features
@@ -33095,7 +33115,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features
id2}@anchor{47a}@anchor{gnat_rm/obsolescent_features
pragma-no-run-time}@anchor{47b}
+@anchor{gnat_rm/obsolescent_features
id2}@anchor{47b}@anchor{gnat_rm/obsolescent_features
pragma-no-run-time}@anchor{47c}
@section pragma No_Run_Time
@@ -33108,7 +33128,7 @@ preferred usage is to use an appropriately configured
run-time that
includes just those features that are to be made accessible.
@node pragma Ravenscar,pragma Restricted_Run_Time,pragma
No_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features
id3}@anchor{47c}@anchor{gnat_rm/obsolescent_features
pragma-ravenscar}@anchor{47d}
+@anchor{gnat_rm/obsolescent_features
id3}@anchor{47d}@anchor{gnat_rm/obsolescent_features
pragma-ravenscar}@anchor{47e}
@section pragma Ravenscar
@@ -33117,7 +33137,7 @@ The pragma @code{Ravenscar} has exactly the same effect
as pragma
is part of the new Ada 2005 standard.
@node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent
Features
-@anchor{gnat_rm/obsolescent_features
id4}@anchor{47e}@anchor{gnat_rm/obsolescent_features
pragma-restricted-run-time}@anchor{47f}
+@anchor{gnat_rm/obsolescent_features
id4}@anchor{47f}@anchor{gnat_rm/obsolescent_features
pragma-restricted-run-time}@anchor{480}
@section pragma Restricted_Run_Time
@@ -33127,7 +33147,7 @@ preferred since the Ada 2005 pragma @code{Profile} is
intended for
this kind of implementation dependent addition.
@node pragma Task_Info,package System Task_Info s-tasinf ads,pragma
Restricted_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features
id5}@anchor{480}@anchor{gnat_rm/obsolescent_features
pragma-task-info}@anchor{481}
+@anchor{gnat_rm/obsolescent_features
id5}@anchor{481}@anchor{gnat_rm/obsolescent_features
pragma-task-info}@anchor{482}
@section pragma Task_Info
@@ -33153,7 +33173,7 @@ in the spec of package System.Task_Info in the runtime
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent
Features
-@anchor{gnat_rm/obsolescent_features
package-system-task-info}@anchor{482}@anchor{gnat_rm/obsolescent_features
package-system-task-info-s-tasinf-ads}@anchor{483}
+@anchor{gnat_rm/obsolescent_features
package-system-task-info}@anchor{483}@anchor{gnat_rm/obsolescent_features
package-system-task-info-s-tasinf-ads}@anchor{484}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -33163,7 +33183,7 @@ to support the @code{Task_Info} pragma. The predefined
Ada package
standard replacement for GNAT’s @code{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation
License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide
doc}@anchor{484}@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide
id1}@anchor{485}
+@anchor{gnat_rm/compatibility_and_porting_guide
doc}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide
id1}@anchor{486}
@chapter Compatibility and Porting Guide
@@ -33185,7 +33205,7 @@ applications developed in other Ada environments.
@end menu
@node Writing Portable Fixed-Point Declarations,Compatibility with Ada
83,,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
id2}@anchor{486}@anchor{gnat_rm/compatibility_and_porting_guide
writing-portable-fixed-point-declarations}@anchor{487}
+@anchor{gnat_rm/compatibility_and_porting_guide
id2}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide
writing-portable-fixed-point-declarations}@anchor{488}
@section Writing Portable Fixed-Point Declarations
@@ -33307,7 +33327,7 @@ If you follow this scheme you will be guaranteed that
your fixed-point
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada
2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-ada-83}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide
id3}@anchor{489}
+@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-ada-83}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide
id3}@anchor{48a}
@section Compatibility with Ada 83
@@ -33335,7 +33355,7 @@ following subsections treat the most likely issues to
be encountered.
@end menu
@node Legal Ada 83 programs that are illegal in Ada 95,More deterministic
semantics,,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide
id4}@anchor{48a}@anchor{gnat_rm/compatibility_and_porting_guide
legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48b}
+@anchor{gnat_rm/compatibility_and_porting_guide
id4}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide
legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48c}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -33435,7 +33455,7 @@ the fix is usually simply to add the @code{(<>)} to the
generic declaration.
@end itemize
@node More deterministic semantics,Changed semantics,Legal Ada 83 programs
that are illegal in Ada 95,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide
id5}@anchor{48c}@anchor{gnat_rm/compatibility_and_porting_guide
more-deterministic-semantics}@anchor{48d}
+@anchor{gnat_rm/compatibility_and_porting_guide
id5}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide
more-deterministic-semantics}@anchor{48e}
@subsection More deterministic semantics
@@ -33463,7 +33483,7 @@ which open select branches are executed.
@end itemize
@node Changed semantics,Other language compatibility issues,More deterministic
semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide
changed-semantics}@anchor{48e}@anchor{gnat_rm/compatibility_and_porting_guide
id6}@anchor{48f}
+@anchor{gnat_rm/compatibility_and_porting_guide
changed-semantics}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide
id6}@anchor{490}
@subsection Changed semantics
@@ -33505,7 +33525,7 @@ covers only the restricted range.
@end itemize
@node Other language compatibility issues,,Changed semantics,Compatibility
with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide
id7}@anchor{490}@anchor{gnat_rm/compatibility_and_porting_guide
other-language-compatibility-issues}@anchor{491}
+@anchor{gnat_rm/compatibility_and_porting_guide
id7}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide
other-language-compatibility-issues}@anchor{492}
@subsection Other language compatibility issues
@@ -33538,7 +33558,7 @@ include @code{pragma Interface} and the floating point
type attributes
@end itemize
@node Compatibility between Ada 95 and Ada 2005,Implementation-dependent
characteristics,Compatibility with Ada 83,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-between-ada-95-and-ada-2005}@anchor{492}@anchor{gnat_rm/compatibility_and_porting_guide
id8}@anchor{493}
+@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-between-ada-95-and-ada-2005}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide
id8}@anchor{494}
@section Compatibility between Ada 95 and Ada 2005
@@ -33610,7 +33630,7 @@ can declare a function returning a value from an
anonymous access type.
@end itemize
@node Implementation-dependent characteristics,Compatibility with Other Ada
Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting
Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
id9}@anchor{494}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-dependent-characteristics}@anchor{495}
+@anchor{gnat_rm/compatibility_and_porting_guide
id9}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-dependent-characteristics}@anchor{496}
@section Implementation-dependent characteristics
@@ -33633,7 +33653,7 @@ transition from certain Ada 83 compilers.
@end menu
@node Implementation-defined pragmas,Implementation-defined
attributes,,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide
id10}@anchor{496}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-defined-pragmas}@anchor{497}
+@anchor{gnat_rm/compatibility_and_porting_guide
id10}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-defined-pragmas}@anchor{498}
@subsection Implementation-defined pragmas
@@ -33655,7 +33675,7 @@ avoiding compiler rejection of units that contain such
pragmas; they are not
relevant in a GNAT context and hence are not otherwise implemented.
@node Implementation-defined attributes,Libraries,Implementation-defined
pragmas,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide
id11}@anchor{498}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-defined-attributes}@anchor{499}
+@anchor{gnat_rm/compatibility_and_porting_guide
id11}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide
implementation-defined-attributes}@anchor{49a}
@subsection Implementation-defined attributes
@@ -33669,7 +33689,7 @@ Ada 83, GNAT supplies the attributes @code{Bit},
@code{Machine_Size} and
@code{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined
attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide
id12}@anchor{49a}@anchor{gnat_rm/compatibility_and_porting_guide
libraries}@anchor{49b}
+@anchor{gnat_rm/compatibility_and_porting_guide
id12}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide
libraries}@anchor{49c}
@subsection Libraries
@@ -33698,7 +33718,7 @@ be preferable to retrofit the application using modular
types.
@end itemize
@node Elaboration order,Target-specific
aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide
elaboration-order}@anchor{49c}@anchor{gnat_rm/compatibility_and_porting_guide
id13}@anchor{49d}
+@anchor{gnat_rm/compatibility_and_porting_guide
elaboration-order}@anchor{49d}@anchor{gnat_rm/compatibility_and_porting_guide
id13}@anchor{49e}
@subsection Elaboration order
@@ -33734,7 +33754,7 @@ pragmas either globally (as an effect of the `-gnatE'
switch) or locally
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent
characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide
id14}@anchor{49e}@anchor{gnat_rm/compatibility_and_porting_guide
target-specific-aspects}@anchor{49f}
+@anchor{gnat_rm/compatibility_and_porting_guide
id14}@anchor{49f}@anchor{gnat_rm/compatibility_and_porting_guide
target-specific-aspects}@anchor{4a0}
@subsection Target-specific aspects
@@ -33747,10 +33767,10 @@ on the robustness of the original design. Moreover,
Ada 95 (and thus
Ada 2005, Ada 2012, and Ada 2022) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT’s approach to these issues is described in @ref{4a0,,Representation
Clauses}.
+GNAT’s approach to these issues is described in @ref{4a1,,Representation
Clauses}.
@node Compatibility with Other Ada Systems,Representation
Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-other-ada-systems}@anchor{4a1}@anchor{gnat_rm/compatibility_and_porting_guide
id15}@anchor{4a2}
+@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-other-ada-systems}@anchor{4a2}@anchor{gnat_rm/compatibility_and_porting_guide
id15}@anchor{4a3}
@section Compatibility with Other Ada Systems
@@ -33793,7 +33813,7 @@ far beyond this minimal set, as described in the next
section.
@end itemize
@node Representation Clauses,Compatibility with HP Ada 83,Compatibility with
Other Ada Systems,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
id16}@anchor{4a3}@anchor{gnat_rm/compatibility_and_porting_guide
representation-clauses}@anchor{4a0}
+@anchor{gnat_rm/compatibility_and_porting_guide
id16}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide
representation-clauses}@anchor{4a1}
@section Representation Clauses
@@ -33886,7 +33906,7 @@ with thin pointers.
@end itemize
@node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and
Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-hp-ada-83}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide
id17}@anchor{4a5}
+@anchor{gnat_rm/compatibility_and_porting_guide
compatibility-with-hp-ada-83}@anchor{4a5}@anchor{gnat_rm/compatibility_and_porting_guide
id17}@anchor{4a6}
@section Compatibility with HP Ada 83
@@ -33916,7 +33936,7 @@ extension of package System.
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license
doc}@anchor{4a6}@anchor{share/gnu_free_documentation_license
gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license
gnu-free-documentation-license}@anchor{4a7}
+@anchor{share/gnu_free_documentation_license
doc}@anchor{4a7}@anchor{share/gnu_free_documentation_license
gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license
gnu-free-documentation-license}@anchor{4a8}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index 34c10198ef3..cc0e6c167fc 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -32,6 +32,7 @@ package body Ch5 is
function P_Case_Statement return Node_Id;
function P_Case_Statement_Alternative return Node_Id;
+ function P_Continue_Statement return Node_Id;
function P_Exit_Statement return Node_Id;
function P_Goto_Statement return Node_Id;
function P_If_Statement return Node_Id;
@@ -76,6 +77,9 @@ package body Ch5 is
procedure Then_Scan;
-- Scan past THEN token, testing for illegal junk after it
+ procedure Parse_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id);
+ -- Common processing for Parse_Continue_Statement and Parse_Exit_Statement.
+
---------------------------------
-- 5.1 Sequence of Statements --
---------------------------------
@@ -511,6 +515,13 @@ package body Ch5 is
P_Assignment_Statement (Id_Node));
Statement_Required := False;
+ elsif Block_Label = Name_Continue
+ and then Token in Tok_Semicolon | Tok_When | Tok_Identifier
+ then
+ Restore_Scan_State (Scan_State_Label); -- to Id
+ Append_To (Statement_List, P_Continue_Statement);
+ Statement_Required := False;
+
-- Check common case of procedure call, another case that
-- we want to speed up as much as possible.
@@ -1995,47 +2006,25 @@ package body Ch5 is
begin
Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
- Scan; -- past EXIT
- if Token = Tok_Identifier then
- Set_Name (Exit_Node, P_Qualified_Simple_Name);
+ Parse_Loop_Flow_Statement (Exit_Node);
- elsif Style_Check then
- -- This EXIT has no name, so check that
- -- the innermost loop is unnamed too.
-
- Check_No_Exit_Name :
- for J in reverse 1 .. Scope.Last loop
- if Scopes (J).Etyp = E_Loop then
- if Present (Scopes (J).Labl)
- and then Comes_From_Source (Scopes (J).Labl)
- then
- -- Innermost loop in fact had a name, style check fails
-
- Style.No_Exit_Name (Scopes (J).Labl);
- end if;
-
- exit Check_No_Exit_Name;
- end if;
- end loop Check_No_Exit_Name;
- end if;
-
- if Token = Tok_When and then not Missing_Semicolon_On_When then
- Scan; -- past WHEN
- Set_Condition (Exit_Node, P_Condition);
-
- -- 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 (Exit_Node, P_Expression_No_Right_Paren);
- end if;
-
- TF_Semicolon;
return Exit_Node;
end P_Exit_Statement;
+ --------------------------------------
+ -- GNAT-specific Continue Statement --
+ --------------------------------------
+
+ function P_Continue_Statement return Node_Id is
+ Continue_Node : constant Node_Id :=
+ New_Node (N_Continue_Statement, Token_Ptr);
+ begin
+ Parse_Loop_Flow_Statement (Continue_Node);
+
+ return Continue_Node;
+ end P_Continue_Statement;
+
-------------------------
-- 5.8 Goto Statement --
-------------------------
@@ -2395,4 +2384,48 @@ package body Ch5 is
end if;
end Then_Scan;
+ -------------------------------
+ -- Parse_Loop_Flow_Statement --
+ -------------------------------
+
+ procedure Parse_Loop_Flow_Statement (N : N_Loop_Flow_Statement_Id) is
+ begin
+ Scan; -- past EXIT or CONTINUE
+
+ if Token = Tok_Identifier then
+ Set_Name (N, P_Qualified_Simple_Name);
+ elsif Style_Check and then Nkind (N) = N_Exit_Statement then
+ -- This statement has no name, so check that
+ -- the innermost loop is unnamed too.
+
+ Check_No_Exit_Name :
+ for J in reverse 1 .. Scope.Last loop
+ if Scopes (J).Etyp = E_Loop then
+ if Present (Scopes (J).Labl)
+ and then Comes_From_Source (Scopes (J).Labl)
+ then
+ -- Innermost loop in fact had a name, style check fails
+
+ Style.No_Exit_Name (Scopes (J).Labl);
+ end if;
+
+ exit Check_No_Exit_Name;
+ end if;
+ end loop Check_No_Exit_Name;
+ end if;
+
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Scan; -- past WHEN
+ Set_Condition (N, P_Condition);
+
+ -- 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 (N, P_Expression_No_Right_Paren);
+ end if;
+
+ TF_Semicolon;
+ end Parse_Loop_Flow_Statement;
end Ch5;
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index 449fd8ad2c4..dcff62e63bc 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -192,6 +192,9 @@ package body Sem is
when N_Conditional_Entry_Call =>
Analyze_Conditional_Entry_Call (N);
+ when N_Continue_Statement =>
+ Analyze_Continue_Statement (N);
+
when N_Delay_Alternative =>
Analyze_Delay_Alternative (N);
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index caba1e215b1..e1d6be424ed 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -90,6 +90,12 @@ package body Sem_Ch5 is
-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
+ function Analyze_Loop_Flow_Statement
+ (N : N_Loop_Flow_Statement_Id) return Opt_E_Loop_Id;
+ -- Perform analysis that is common to continue statements and exit
+ -- statements. On success, the return value is the entity of the loop
+ -- referenced by the statement.
+
function Has_Sec_Stack_Call (N : Node_Id) return Boolean;
-- N is the node for an arbitrary construct. This function searches the
-- construct N to see if it contains a function call that returns on the
@@ -1663,6 +1669,112 @@ package body Sem_Ch5 is
end if;
end Analyze_Case_Statement;
+ --------------------------------
+ -- Analyze_Continue_Statement --
+ --------------------------------
+
+ procedure Analyze_Continue_Statement (N : Node_Id) is
+ Ignore_Errors_On_Entry : constant Boolean := Get_Ignore_Errors;
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Nam : constant Node_Id := Name (N);
+ Cond : constant Node_Id := Condition (N);
+
+ function Make_Call return N_Procedure_Call_Statement_Id;
+ -- Build a node that corresponds to the procedure call interpretation of
+ -- N.
+
+ function Make_Stmt return N_Continue_Statement_Id;
+ -- Build a node that corresponds to the continue statement
+ -- interpretation of N.
+
+ function Make_Call return N_Procedure_Call_Statement_Id is
+ begin
+ return
+ Make_Procedure_Call_Statement
+ (Loc, Make_Identifier (Loc, Name_Continue));
+ end Make_Call;
+
+ function Make_Stmt return N_Continue_Statement_Id is
+ begin
+ return Make_Continue_Statement (Loc, Nam, Cond);
+ end Make_Stmt;
+
+ Continue_Is_Available : constant Boolean :=
+ Ada_Version = Ada_With_All_Extensions;
+
+ Maybe_Procedure_Call : constant Boolean :=
+ No (Name (N)) and then No (Condition (N));
+ begin
+ if Maybe_Procedure_Call and then Continue_Is_Available then
+ -- This is the tricky case. The idea is to do a kind of overload
+ -- resolution of a procedure call, but with "continue statement" as
+ -- an additional possible interpretation. To achieve this, we
+ -- temporarily replace N with a procedure call statement and analyze
+ -- it in "ignore errors" mode.
+ Replace (N, Make_Call);
+ Set_Ignore_Errors (True);
+ Analyze (N);
+ Set_Ignore_Errors (Ignore_Errors_On_Entry);
+
+ declare
+ C : constant N_Procedure_Call_Statement_Id := New_Copy (N);
+ -- C is the result of our procedure call interpretation analysis
+ begin
+ -- We restore N to a continue statement
+ Replace (N, Make_Stmt);
+
+ if Is_Overloaded (Name (C)) then
+ -- There are multiple valid procedure call interpretations; we
+ -- don't mention the possible interpretation as a continue
+ -- statement for now. It might be possible to add this in the
+ -- future.
+
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ elsif Etype (C) = Any_Type then
+ -- There is no valid procedure call interpretation. We go for
+ -- the continue statement interpretation. It might not be valid
+ -- either, but we make the assumption that the user meant to
+ -- write a continue statement and not a procedure call and emit
+ -- error messages accordingly.
+
+ Set_Call_Or_Target_Loop (N, Analyze_Loop_Flow_Statement (N));
+ else
+ -- There is a unique valid procedure call interpretation. We
+ -- test whether the interpretation as a continue statement is
+ -- valid.
+
+ declare
+ L : Opt_E_Loop_Id;
+ begin
+ Set_Ignore_Errors (True);
+ L := Analyze_Loop_Flow_Statement (N);
+ Set_Ignore_Errors (Ignore_Errors_On_Entry);
+
+ if Present (L) then
+ -- If the continue statement interpretation makes sense,
+ -- we post an ad hoc ambiguity error.
+ Error_Msg_N
+ ("ambiguity between continue statement and call", N);
+ else
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ end if;
+ end;
+ end if;
+ end;
+ elsif Maybe_Procedure_Call then
+ Set_Call_Or_Target_Loop (N, Make_Call);
+ elsif Continue_Is_Available then
+ Set_Call_Or_Target_Loop (N, Analyze_Loop_Flow_Statement (N));
+ else
+ Error_Msg_GNAT_Extension
+ (Extension => "continue",
+ Loc => Sloc (N),
+ Is_Core_Extension => False);
+ end if;
+ end Analyze_Continue_Statement;
+
----------------------------
-- Analyze_Exit_Statement --
----------------------------
@@ -1682,99 +1794,16 @@ package body Sem_Ch5 is
-- in a loop. The exit must be the last statement in the if-statement.
procedure Analyze_Exit_Statement (N : Node_Id) is
- Target : constant Node_Id := Name (N);
- Cond : constant Node_Id := Condition (N);
- Scope_Id : Entity_Id := Empty; -- initialize to prevent warning
- U_Name : Entity_Id;
- Kind : Entity_Kind;
-
+ L : constant Opt_E_Loop_Id := Analyze_Loop_Flow_Statement (N);
begin
- if No (Cond) then
- Check_Unreachable_Code (N);
+ if Present (L) then
+ Set_Has_Exit (L);
+
+ -- Chain exit statement to associated loop entity
+
+ Set_Next_Exit_Statement (N, First_Exit_Statement (L));
+ Set_First_Exit_Statement (L, N);
end if;
-
- if Present (Target) then
- Analyze (Target);
- U_Name := Entity (Target);
-
- if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
- Error_Msg_N ("invalid loop name in exit statement", N);
- return;
-
- else
- Set_Has_Exit (U_Name);
- end if;
-
- else
- U_Name := Empty;
- end if;
-
- for J in reverse 0 .. Scope_Stack.Last loop
- Scope_Id := Scope_Stack.Table (J).Entity;
- Kind := Ekind (Scope_Id);
-
- if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
- Set_Has_Exit (Scope_Id);
- exit;
-
- elsif Kind = E_Block
- or else Kind = E_Loop
- or else Kind = E_Return_Statement
- then
- null;
-
- else
- Error_Msg_N
- ("cannot exit from program unit or accept statement", N);
- return;
- end if;
- end loop;
-
- Finally_Legality_Check : declare
- -- The following value can actually be a block statement due to
- -- expansion, but we call it Target_Loop_Statement because it was
- -- originally a loop statement.
- Target_Loop_Statement : constant Node_Id :=
- (if Present (U_Name) then Label_Construct ((Parent (U_Name)))
- else Empty);
-
- X : Node_Id := N;
- begin
- while Present (X) loop
- if Nkind (X) = N_Loop_Statement
- and then (No (Target_Loop_Statement)
- or else X = Target_Loop_Statement)
- then
- exit;
- elsif Nkind (Parent (X)) = N_Handled_Sequence_Of_Statements
- and then Is_List_Member (X)
- and then List_Containing (X) = Finally_Statements (Parent (X))
- then
- Error_Msg_N ("cannot exit out of finally part", N);
- exit;
- end if;
- X := Parent (X);
- end loop;
- end Finally_Legality_Check;
-
- -- Verify that if present the condition is a Boolean expression
-
- if Present (Cond) then
- Analyze_And_Resolve (Cond, Any_Boolean);
- Check_Unset_Reference (Cond);
- end if;
-
- -- Chain exit statement to associated loop entity
-
- Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id));
- Set_First_Exit_Statement (Scope_Id, N);
-
- -- Since the exit may take us out of a loop, any previous assignment
- -- statement is not useless, so clear last assignment indications. It
- -- is OK to keep other current values, since if the exit statement
- -- does not exit, then the current values are still valid.
-
- Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Exit_Statement;
----------------------------
@@ -3997,6 +4026,18 @@ package body Sem_Ch5 is
Set_Has_Created_Identifier (N);
end if;
+ if No (Continue_Mark (Ent)) then
+ -- If Continue_Mark wasn't set on the loop entity, we know that N
+ -- does not come from the expansion of iterators that append
+ -- statements to advance the loop, so right after the last statement
+ -- in the list is where continue statements must jump to.
+ Set_Continue_Mark (Ent, Last (Statements (N)));
+ else
+ -- Otherwise, N somehow derives from another loop statement, the
+ -- analysis of which set Continue_Mark adequately already.
+ null;
+ end if;
+
-- Determine whether the loop statement must be transformed prior to
-- analysis, and if so, perform it. This early modification is needed
-- when:
@@ -4206,6 +4247,105 @@ package body Sem_Ch5 is
end if;
end Analyze_Loop_Statement;
+ ---------------------------------
+ -- Analyze_Loop_Flow_Statement --
+ ---------------------------------
+
+ function Analyze_Loop_Flow_Statement
+ (N : N_Loop_Flow_Statement_Id) return Opt_E_Loop_Id
+ is
+ Target : constant Node_Id := Name (N);
+ Cond : constant Node_Id := Condition (N);
+ Scope_Id : Entity_Id := Empty;
+ U_Name : Entity_Id;
+ Kind : Entity_Kind;
+
+ S : constant String := Loop_Flow_Keyword (N);
+ begin
+ if No (Cond) then
+ Check_Unreachable_Code (N);
+ end if;
+
+ if Present (Target) then
+ Analyze (Target);
+ U_Name := Entity (Target);
+
+ if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
+ Error_Msg_N ("invalid loop name in " & S & " statement", N);
+ return Empty;
+ end if;
+
+ else
+ U_Name := Empty;
+ end if;
+
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scope_Id := Scope_Stack.Table (J).Entity;
+ Kind := Ekind (Scope_Id);
+
+ if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
+ exit;
+
+ elsif Kind = E_Block
+ or else Kind = E_Loop
+ or else Kind = E_Return_Statement
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("cannot " & S & " from program unit or accept statement", N);
+ return Empty;
+ end if;
+ end loop;
+
+ Finally_Legality_Check :
+ declare
+ -- The following value can actually be a block statement due to
+ -- expansion, but we call it Target_Loop_Statement because it was
+ -- originally a loop statement.
+ Target_Loop_Statement : constant Node_Id :=
+ (if Present (U_Name)
+ then Label_Construct ((Parent (U_Name)))
+ else Empty);
+
+ X : Node_Id := N;
+ begin
+ while Present (X) loop
+ if Nkind (X) = N_Loop_Statement
+ and then (No (Target_Loop_Statement)
+ or else X = Target_Loop_Statement)
+ then
+ exit;
+ elsif Nkind (Parent (X)) = N_Handled_Sequence_Of_Statements
+ and then Is_List_Member (X)
+ and then List_Containing (X) = Finally_Statements (Parent (X))
+ then
+ Error_Msg_N ("cannot " & S & " out of finally part", N);
+ exit;
+ end if;
+ X := Parent (X);
+ end loop;
+ end Finally_Legality_Check;
+
+ -- Verify that if present the condition is a Boolean expression
+
+ if Present (Cond) then
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+ end if;
+
+ -- Since the statement may take us out of the current iteration of the
+ -- loop, any previous assignment statement is not useless, so clear last
+ -- assignment indications. It is OK to keep other current values, since
+ -- if the statement does not stop the current iteration, then the
+ -- current values are still valid.
+
+ Kill_Current_Values (Last_Assignment_Only => True);
+
+ return Scope_Id;
+ end Analyze_Loop_Flow_Statement;
+
----------------------------
-- Analyze_Null_Statement --
----------------------------
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index 03bfc01d25e..3a6c90e0460 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -31,6 +31,7 @@ package Sem_Ch5 is
procedure Analyze_Block_Statement (N : Node_Id);
procedure Analyze_Case_Statement (N : Node_Id);
procedure Analyze_Compound_Statement (N : Node_Id);
+ procedure Analyze_Continue_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);
diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb
index 184bb08db12..d2e78a3b4b7 100644
--- a/gcc/ada/sinfo-utils.adb
+++ b/gcc/ada/sinfo-utils.adb
@@ -347,6 +347,19 @@ package body Sinfo.Utils is
end if;
end Get_Pragma_Arg;
+ -----------------------
+ -- Loop_Flow_Keyword --
+ -----------------------
+
+ function Loop_Flow_Keyword (N : N_Loop_Flow_Statement_Id) return String is
+ begin
+ case Nkind (N) is
+ when N_Continue_Statement => return "continue";
+ when N_Exit_Statement => return "exit";
+ when others => pragma Assert (False);
+ end case;
+ end Loop_Flow_Keyword;
+
procedure Destroy_Element (Elem : in out Union_Id);
-- Does not do anything but is used to instantiate
-- GNAT.Lists.Doubly_Linked_Lists.
diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads
index 0e7399e08b7..3ef85e6926d 100644
--- a/gcc/ada/sinfo-utils.ads
+++ b/gcc/ada/sinfo-utils.ads
@@ -137,6 +137,10 @@ package Sinfo.Utils is
-- for the argument. This is Arg itself, or, in the case where Arg is a
-- pragma argument association node, the expression from this node.
+ function Loop_Flow_Keyword (N : N_Loop_Flow_Statement_Id) return String;
+ -- Returns the keyword corresponding to N as a string, for use in
+ -- diagnostics.
+
function Lowest_Common_Ancestor (N1, N2 : Node_Id) return Union_Id;
-- Returns the list or node that is the lowest common ancestor of N1 and
-- N2 in the syntax tree.
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 9b5d3c29ca4..c63a97dbcc6 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -2312,6 +2312,15 @@ package Sinfo is
-- entity of the original entity, operator, or subprogram being invoked,
-- or the original variable being read or written.
+ -- Call_Or_Target_Loop
+ -- Present in continue statements. Set by Analyze_Continue_Statement and
+ -- used by Expand_Continue_Statement. If Analyze_Continue_Statement
+ -- concluded that its input node was in fact a call to a procedure named
+ -- "Continue", it contains the corresponding N_Procedure_Call_Statement
+ -- node. Otherwise it contains the E_Loop_Id of the loop the continue
+ -- statement applies to. Finally, if Analyze_Continue_Statement detects
+ -- an error, this field is set to Empty.
+
-- Target_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
@@ -5207,6 +5216,23 @@ package Sinfo is
-- Condition (set to Empty if no WHEN part present)
-- Next_Exit_Statement : Next exit on chain
+ ------------------------
+ -- Continue Statement --
+ ------------------------
+
+ -- This is a GNAT extension
+
+ -- CONTINUE_STATEMENT ::= continue [loop_NAME] [when CONDITION];
+
+ -- Gigi restriction: The expander ensures that the type of the Condition
+ -- field is always Standard.Boolean, even if the type in the source is
+ -- some non-standard boolean type.
+
+ -- N_Continue_Statement
+ -- Sloc points to CONTINUE
+ -- Name (set to Empty if no loop name present)
+ -- Condition (set to Empty if no WHEN part present)
+
-------------------------
-- 5.9 Goto Statement --
-------------------------
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 06d9c4b8d47..84bee722c76 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -1391,6 +1391,7 @@ package Snames is
-- e.g. Name_UP_RESULT maps to "RESULT".
Name_Synchronous_Task_Control : constant Name_Id := N + $;
+ Name_Continue : constant Name_Id := N + $;
-- Names used to implement iterators over predefined containers
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 6b74be14b40..7a9749287af 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -1772,8 +1772,8 @@ package body Sprint is
Sprint_Node (Name (Node));
Write_Char (';');
- when N_Exit_Statement =>
- Write_Indent_Str_Sloc ("exit");
+ when N_Loop_Flow_Statement =>
+ Write_Indent_Str_Sloc (Loop_Flow_Keyword (Node));
Sprint_Opt_Node (Name (Node));
if Present (Condition (Node)) then
--
2.43.0
