[flang] Allow labels on END statements.

[klausler]

Summary

F18 clause 5.3.3 explicitly allows labels on program unit END statements.
Label resolution code accounts for this for singleton program units,
but incorrectly generates an error for host subprograms with internal
subprograms.

   subroutine s(n)
      call s1(n)
      if (n == 0) goto 88 ! incorrect error
      print*, 's'
   contains
      subroutine s1(n)
         if (n == 0) goto 77 ! ok
         print*, 's1'
   77 end subroutine s1
   88 end

Label resolution code makes a sequential pass over an entire file to
collect label information for all subprograms, followed by a pass through
that information for semantics checks.  The problem is that END statements
may be separated from prior subprogram code by internal subprogram
definitions, so an END label can be associated with the wrong subprogram.

There are several ways to fix this.  Labels are always local to a
subprogram.  So the two separate passes over the entire file could probably
instead be interleaved to perform analysis on a subprogram as soon as the
end of the subprogram is reached, using a small stack.  The stack structure
would account for the "split" code case.  This might work.

It is possible that there is some not otherwise apparent advantage to
the current full-file pass design.  The parse tree has productions that
provide access to a subprogram END statement "in advance".  An alternative
is to access this information to solve the problem.  This PR implements
this latter option.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/lib/Semantics/resolve-labels.cpp

if constexpr (WrapperTrait<A>) {
     name = &std::get<std::optional<parser::Name>>(stmt.statement.t);
   }
   if (name && *name) {
     return &(*name)->source;
   }
   return nullptr;
 }
 
-using ExecutableConstructEndStmts = std::tuple<parser::EndIfStmt,
-    parser::EndDoStmt, parser::EndSelectStmt, parser::EndChangeTeamStmt,
-    parser::EndBlockStmt, parser::EndCriticalStmt, parser::EndAssociateStmt>;
-
-template <typename A>
-static constexpr bool IsExecutableConstructEndStmt{
-    common::HasMember<A, ExecutableConstructEndStmts>};
-
 class ParseTreeAnalyzer {
 public:
   ParseTreeAnalyzer(ParseTreeAnalyzer &&that) = default;
   ParseTreeAnalyzer(SemanticsContext &context) : context_{context} {}
 
-  template <typename A> constexpr bool Pre(const A &) { return true; }
+  template <typename A> constexpr bool Pre(const A &x) {
+    using LabeledProgramUnitStmts =
+        std::tuple<parser::MainProgram, parser::FunctionSubprogram,
+            parser::SubroutineSubprogram, parser::SeparateModuleSubprogram>;
+    if constexpr (common::HasMember<A, LabeledProgramUnitStmts>) {
+      const auto &endStmt{std::get<std::tuple_size_v<decltype(x.t)> - 1>(x.t)};
+      if (endStmt.label) {
+        // The END statement for a subprogram appears after any internal
+        // subprograms.  Visit that statement in advance so that results
+        // are placed in the correct programUnits_ slot.
+        auto targetFlags{ConstructBranchTargetFlags(endStmt)};
+        AddTargetLabelDefinition(
+            endStmt.label.value(), targetFlags, currentScope_);
+      }
+    }
+    return true;
+  }
   template <typename A> constexpr void Post(const A &) {}
 
   template <typename A> bool Pre(const parser::Statement<A> &statement) {
     currentPosition_ = statement.source;
-    if (statement.label) {
-      auto label{statement.label.value()};
-      auto targetFlags{ConstructBranchTargetFlags(statement)};
-      if constexpr (std::is_same_v<A, parser::AssociateStmt> ||
-          std::is_same_v<A, parser::BlockStmt> ||
-          std::is_same_v<A, parser::ChangeTeamStmt> ||
-          std::is_same_v<A, parser::CriticalStmt> ||
-          std::is_same_v<A, parser::NonLabelDoStmt> ||
-          std::is_same_v<A, parser::IfThenStmt> ||
-          std::is_same_v<A, parser::SelectCaseStmt> ||
-          std::is_same_v<A, parser::SelectRankStmt> ||
-          std::is_same_v<A, parser::SelectTypeStmt>) {
-        constexpr bool useParent{true};
-        AddTargetLabelDefinition(
-            useParent, label, targetFlags, IsExecutableConstructEndStmt<A>);
-      } else {
-        constexpr bool useParent{false};
-        AddTargetLabelDefinition(
-            useParent, label, targetFlags, IsExecutableConstructEndStmt<A>);
-      }
+    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 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};
+      AddTargetLabelDefinition(label.value(), targetFlags, currentScope_,
+          isExecutableConstructEndStmt);
+    } else if constexpr (!common::HasMember<A, LabeledProgramUnitEndStmts>) {
+      // Program unit END statements have already been processed.
+      AddTargetLabelDefinition(label.value(), targetFlags, currentScope_);
     }
     return true;
   }
 
   // see 11.1.1
   bool Pre(const parser::ProgramUnit &) { return InitializeNewScopeContext(); }
   bool Pre(const parser::InternalSubprogram &) {
     return InitializeNewScopeContext();
void CheckLabelInRange(parser::Label label) {
     if (label < 1 || label > 99999) {
       context_.Say(currentPosition_,
           parser::MessageFormattedText{
               "Label '%u' is out of range"_err_en_US, SayLabel(label)});
     }
   }
 
   // 6.2.5., paragraph 2
-  void AddTargetLabelDefinition(bool useParent, parser::Label label,
+  void AddTargetLabelDefinition(parser::Label label,
       LabeledStmtClassificationSet labeledStmtClassificationSet,
-      bool isExecutableConstructEndStmt) {
+      ProxyForScope scope, bool isExecutableConstructEndStmt = false) {
     CheckLabelInRange(label);
     const auto pair{programUnits_.back().targetStmts.emplace(label,
-        LabeledStatementInfoTuplePOD{
-            (useParent ? ParentScope() : currentScope_), currentPosition_,
+        LabeledStatementInfoTuplePOD{scope, currentPosition_,
             labeledStmtClassificationSet, isExecutableConstructEndStmt})};
     if (!pair.second) {
       context_.Say(currentPosition_,
           parser::MessageFormattedText{
               "Label '%u' is not distinct"_err_en_US, SayLabel(label)});
     }
   }
 

flang/test/Semantics/label15.f90

+! RUN: %f18 -funparse %s 2>&1 | FileCheck %s
+
+!CHECK-NOT: error:
+module mm
+   interface
+      module subroutine m(n)
+      end
+   end interface
+end module mm
+
+program p
+   use mm
+20 print*, 'p'
+21 call p1
+22 call p2
+23 f0 = f(0); print '(f5.1)', f0
+24 f1 = f(1); print '(f5.1)', f1
+25 call s(0); call s(1)
+26 call m(0); call m(1)
+27 if (.false.) goto 29
+28 print*, 'px'
+contains
+   subroutine p1
+      print*, 'p1'
+      goto 29
+29 end subroutine p1
+   subroutine p2
+      print*, 'p2'
+      goto 29
+29 end subroutine p2
+29 end
+
+function f(n)
+   print*, 'f'
+31 call f1
+32 call f2
+   f = 30.
+   if (n == 0) goto 39
+   f = f + 3.
+   print*, 'fx'
+contains
+   subroutine f1
+      print*, 'f1'
+      goto 39
+39 end subroutine f1
+   subroutine f2
+      print*, 'f2'
+      goto 39
+39 end subroutine f2
+39 end
+
+subroutine s(n)
+   print*, 's'
+41 call s1
+42 call s2
+43 call s3
+   if (n == 0) goto 49
+   print*, 'sx'
+contains
+   subroutine s1
+      print*, 's1'
+      goto 49
+49 end subroutine s1
+   subroutine s2
+      print*, 's2'
+      goto 49
+49 end subroutine s2
+   subroutine s3
+      print*, 's3'
+      goto 49
+49 end subroutine s3
+49 end
+
+submodule(mm) mm1
+contains
+   module procedure m
+      print*, 'm'
+   50 call m1
+   51 call m2
+      if (n == 0) goto 59
+      print*, 'mx'
+   contains
+      subroutine m1
+         print*, 'm1'
+         goto 59
+   59 end subroutine m1
+      subroutine m2
+         print*, 'm2'
+         goto 59
+   59 end subroutine m2
+   59 end procedure m
+end submodule mm1

flang/test/Semantics/label16.f90

+! RUN: %S/test_errors.sh %s %t %f18
+
+subroutine x(n)
+   call x1(n)
+   if (n == 0) goto 88
+   print*, 'x'
+contains
+   subroutine x1(n)
+      if (n == 0) goto 77 ! ok
+      print*, 'x1'
+      !ERROR: Label '88' was not found
+      goto 88
+77 end subroutine x1
+88 end