[flang] Catch branching into FORALL/WHERE constructs

[klausler]

Summary

Enforce constraints C1034 & C1038, which disallow the use
of otherwise valid statements as branch targets when they
appear in FORALL &/or WHERE constructs. (And make the
diagnostic message somewhat more user-friendly.)

[klausler]

ping

[rovka]

Shouldn't you add new testcases with forall and where (and while you're at it, maybe also with select and the others that aren't covered by these 4 tests)?

flang/lib/Semantics/resolve-labels.cpp

230

Nitpick: I think this tuple was sorted alphabetically before.

[klausler]

Address comments from Diana P.

[rovka]

LGTM, thanks.

flang/lib/Semantics/resolve-labels.cpp

 constexpr Legality IsLegalDoTerm(const parser::Statement<A> &) {
   if (std::is_same_v<A, common::Indirection<parser::EndDoStmt>> ||
       std::is_same_v<A, parser::EndDoStmt>) {
     return Legality::always;
   } else if (std::is_same_v<A, parser::EndForallStmt> ||
       std::is_same_v<A, parser::EndWhereStmt>) {
     // Executable construct end statements are also supported as
     // an extension but they need special care because the associated
-    // construct create there own scope.
+    // construct create their own scope.
     return Legality::formerly;
   } else {
     return Legality::never;
   }
 }
 
 constexpr Legality IsLegalDoTerm(
     const parser::Statement<parser::ActionStmt> &actionStmt) {
template <typename A> bool Pre(const parser::Statement<A> &statement) {
     const auto &label = statement.label;
     if (!label) {
       return true;
     }
     using LabeledConstructStmts = std::tuple<parser::AssociateStmt,
         parser::BlockStmt, parser::ChangeTeamStmt, parser::CriticalStmt,
         parser::IfThenStmt, parser::NonLabelDoStmt, parser::SelectCaseStmt,
         parser::SelectRankStmt, parser::SelectTypeStmt>;
-    using LabeledConstructEndStmts =
-        std::tuple<parser::EndAssociateStmt, parser::EndBlockStmt,
-            parser::EndChangeTeamStmt, parser::EndCriticalStmt,
-            parser::EndDoStmt, parser::EndIfStmt, parser::EndSelectStmt>;
+    using LabeledConstructEndStmts = std::tuple<parser::EndAssociateStmt,
+        parser::EndBlockStmt, parser::EndChangeTeamStmt,
+        parser::EndCriticalStmt, parser::EndDoStmt, parser::EndForallStmt,
+        parser::EndIfStmt, parser::EndSelectStmt, parser::EndWhereStmt>;
     using LabeledProgramUnitEndStmts =
         std::tuple<parser::EndFunctionStmt, parser::EndMpSubprogramStmt,
             parser::EndProgramStmt, parser::EndSubroutineStmt>;
     auto targetFlags{ConstructBranchTargetFlags(statement)};
     if constexpr (common::HasMember<A, LabeledConstructStmts>) {
       AddTargetLabelDefinition(label.value(), targetFlags, ParentScope());
     } else if constexpr (common::HasMember<A, LabeledConstructEndStmts>) {
       constexpr bool isExecutableConstructEndStmt{true};
public:
   }
   bool Pre(const parser::SelectTypeConstruct &selectTypeConstruct) {
     return PushConstructName(selectTypeConstruct);
   }
   bool Pre(const parser::SelectTypeConstruct::TypeCase &) {
     return SwitchToNewScope();
   }
   bool Pre(const parser::WhereConstruct &whereConstruct) {
-    return PushConstructNameWithoutBlock(whereConstruct);
+    return PushConstructName(whereConstruct);
   }
   bool Pre(const parser::ForallConstruct &forallConstruct) {
-    return PushConstructNameWithoutBlock(forallConstruct);
+    return PushConstructName(forallConstruct);
   }
 
   void Post(const parser::AssociateConstruct &associateConstruct) {
     PopConstructName(associateConstruct);
   }
   void Post(const parser::BlockConstruct &blockConstruct) {
     PopConstructName(blockConstruct);
   }
void Post(const parser::CaseConstruct &caseConstruct) {
     PopConstructName(caseConstruct);
   }
   void Post(const parser::SelectRankConstruct &selectRankConstruct) {
     PopConstructName(selectRankConstruct);
   }
   void Post(const parser::SelectTypeConstruct &selectTypeConstruct) {
     PopConstructName(selectTypeConstruct);
   }
-
   void Post(const parser::WhereConstruct &whereConstruct) {
-    PopConstructNameWithoutBlock(whereConstruct);
+    PopConstructName(whereConstruct);
   }
   void Post(const parser::ForallConstruct &forallConstruct) {
-    PopConstructNameWithoutBlock(forallConstruct);
+    PopConstructName(forallConstruct);
   }
 
   // Checks for missing or mismatching names on various constructs (e.g., IF)
   // and their intermediate or terminal statements that allow optional
   // construct names(e.g., ELSE).  When an optional construct name is present,
   // the construct as a whole must have a name that matches.
   template <typename FIRST, typename CONSTRUCT, typename STMT>
   void CheckOptionalName(const char *constructTag, const CONSTRUCT &a,
bool PushConstructName(const parser::BlockConstruct &blockConstruct) {
     const auto &optionalName{
         std::get<parser::Statement<parser::BlockStmt>>(blockConstruct.t)
             .statement.v};
     if (optionalName) {
       constructNames_.emplace_back(optionalName->ToString());
     }
     return PushSubscope();
   }
-  template <typename A> bool PushConstructNameWithoutBlock(const A &a) {
-    const auto &optionalName{std::get<0>(std::get<0>(a.t).statement.t)};
-    if (optionalName) {
-      constructNames_.emplace_back(optionalName->ToString());
-    }
-    return true;
-  }
-
-  template <typename A> void PopConstructNameWithoutBlock(const A &a) {
-    CheckName(a);
-    PopConstructNameIfPresent(a);
-  }
   template <typename A> void PopConstructNameIfPresent(const A &a) {
     const auto &optionalName{std::get<0>(std::get<0>(a.t).statement.t)};
     if (optionalName) {
       constructNames_.pop_back();
     }
   }
   void PopConstructNameIfPresent(const parser::BlockConstruct &blockConstruct) {
     const auto &optionalName{
for (const auto &stmt : stmts) {
     const auto &position{stmt.parserCharBlock};
     auto target{GetLabel(labels, label)};
     if (!HasScope(target.proxyForScope)) {
       context.Say(
           position, "Label '%u' was not found"_err_en_US, SayLabel(label));
     } else if (!InInclusiveScope(scopes, scope, target.proxyForScope)) {
       // Clause 11.1.2.1 prohibits transfer of control to the interior of a
       // block from outside the block, but this does not apply to formats.
+      // C1038 and C1034 forbid statements in FORALL and WHERE constructs
+      // (resp.) from being branch targets.
       if (target.labeledStmtClassificationSet.test(
               TargetStatementEnum::Format)) {
         continue;
       }
-      context.Say(
-          position, "Label '%u' is not in scope"_en_US, SayLabel(label));
+      context.Say(position,
+          "Label '%u' is in a construct that prevents its use as a branch target here"_en_US,
+          SayLabel(label));
     }
   }
 }
 
 void CheckBranchTargetConstraints(const SourceStmtList &stmts,
     const TargetStmtMap &labels, SemanticsContext &context) {
   for (const auto &stmt : stmts) {
     const auto &label{stmt.parserLabel};

flang/test/Semantics/label05.f90

-
 ! RUN: not %flang_fc1 -fdebug-unparse-with-symbols %s 2>&1 | FileCheck %s
 ! CHECK: Label '50' was not found
-! CHECK: Label '55' is not in scope
+! CHECK: Label '55' is in a construct that prevents its use as a branch target here
 ! CHECK: Label '70' is not a branch target
 ! CHECK: Control flow use of '70'
+! CHECK: Label '80' is in a construct that prevents its use as a branch target here
+! CHECK: Label '90' is in a construct that prevents its use as a branch target here
+! CHECK: Label '91' is in a construct that prevents its use as a branch target here
+! CHECK: Label '92' is in a construct that prevents its use as a branch target here
 
 subroutine sub00(a,b,n,m)
   real a(n,m)
   real b(n,m)
   if (n .ne. m) then
      goto 50
   end if
 6 n = m
subroutine sub02(a,b,n,m)
   real b(n,m)
   if (n .ne. m) then
      goto 70
   else
      return
   end if
 70 FORMAT (1x,i6)
 end subroutine sub02
+
+subroutine sub03(a,n)
+  real a(n)
+  forall (j=1:n)
+80  a(n) = j
+  end forall
+  go to 80
+end subroutine sub03
+
+subroutine sub04(a,n)
+  real a(n)
+  where (a > 0)
+90  a = 1
+  elsewhere (a < 0)
+91  a = 2
+  elsewhere
+92  a = 3
+  end where
+  if (n - 3) 90, 91, 92
+end subroutine sub04

flang/test/Semantics/label06.f90

-
 ! RUN: not %flang_fc1 -fdebug-unparse-with-symbols %s 2>&1 | FileCheck %s
-! CHECK: Label '10' is not in scope
+! CHECK: Label '10' is in a construct that prevents its use as a branch target here
 ! CHECK: Label '20' was not found
 ! CHECK: Label '30' is not a branch target
 ! CHECK: Control flow use of '30'
-! CHECK: Label '40' is not in scope
-! CHECK: Label '50' is not in scope
+! CHECK: Label '40' is in a construct that prevents its use as a branch target here
+! CHECK: Label '50' is in a construct that prevents its use as a branch target here
 
 subroutine sub00(n)
   GOTO (10,20,30) n
   if (n .eq. 1) then
 10   print *, "xyz"
   end if
 30 FORMAT (1x,i6)
 end subroutine sub00

flang/test/Semantics/label07.f90

-
 ! RUN: not %flang_fc1 -fdebug-unparse-with-symbols %s 2>&1 | FileCheck %s
 ! CHECK: Label '30' is not a branch target
 ! CHECK: Control flow use of '30'
-! CHECK: Label '10' is not in scope
+! CHECK: Label '10' is in a construct that prevents its use as a branch target here
 ! CHECK: Label '20' was not found
 ! CHECK: Label '60' was not found
 
 subroutine sub00(n,m)
 30 format (i6,f6.2)
   if (n .eq. m) then
 10   print *,"equal"
   end if
   call sub01(n,*10,*20,*30)
   write (*,60) n, m
 end subroutine sub00

flang/test/Semantics/label14.f90

 ! Tests implemented for this standard
 ! 11.1.4 - 4 It is permissible to branch to and end-block-stmt only withinh its
 !            Block Construct
 
 ! RUN: %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
-! CHECK: Label '20' is not in scope
+! CHECK: Label '20' is in a construct that prevents its use as a branch target here
 
 subroutine s1
   block
     goto (10) 1
 10  end block
 
   block
 20  end block