[flang] Nonconformant assigned gotos

[vdonaldson]

Summary

Modify code generation for assigned GOTOs to generate a runtime error
for most cases that violate F90 Clause 8.2.4, rather than treating a
nonconformant GOTO as a nop. For example, generate a runtime error for
a GOTO that attempts to branch to a label for a FORMAT statement.
Relax the requirement that an assigned GOTO with a label list must
branch to a label in the list, and instead allow a branch to any valid
assigned GOTO target in scope.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[vdonaldson]

https://reviews.llvm.org/D147650

flang/lib/Lower/Bridge.cpp

 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Assign.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
 #include "flang/Optimizer/Builder/Runtime/Ragged.h"
+#include "flang/Optimizer/Builder/Runtime/Stop.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/Support/FIRContext.h"
 #include "flang/Optimizer/HLFIR/HLFIROps.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Optimizer/Support/InternalNames.h"
genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) {
     }
     genBranch(targetEval.block);
   }
 
   /// Generate a SelectOp or branch sequence that compares \p selector against
   /// values in \p valueList and targets corresponding labels in \p labelList.
   /// If no value matches the selector, branch to \p defaultEval.
   ///
-  /// There are two special cases.
+  /// Three cases require special processing.
   ///
   /// An empty \p valueList indicates an ArithmeticIfStmt context that requires
   /// two comparisons against 0 or 0.0. The selector may have either INTEGER
   /// or REAL type.
   ///
   /// A nonpositive \p valuelist value indicates an IO statement context
   /// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for
   /// any positive (IOSTAT) value. A missing (zero) label requires a branch
   /// to \p defaultEval for that value.
   ///
+  /// A non-null \p errorBlock indicates an AssignedGotoStmt context that
+  /// must always branch to an explicit target. There is no valid defaultEval
+  /// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt
+  /// that violates this program requirement.
+  ///
   /// If this is not an ArithmeticIfStmt and no targets have exit code,
   /// generate a SelectOp. Otherwise, for each target, if it has exit code,
   /// branch to a new block, insert exit code, and then branch to the target.
   /// Otherwise, branch directly to the target.
   void genMultiwayBranch(mlir::Value selector,
                          llvm::SmallVector<int64_t> valueList,
                          llvm::SmallVector<Fortran::parser::Label> labelList,
-                         const Fortran::lower::pft::Evaluation &defaultEval) {
+                         const Fortran::lower::pft::Evaluation &defaultEval,
+                         mlir::Block *errorBlock = nullptr) {
     bool inArithmeticIfContext = valueList.empty();
     assert(((inArithmeticIfContext && labelList.size() == 2) ||
             (valueList.size() && labelList.size() == valueList.size())) &&
            "mismatched multiway branch targets");
-    bool defaultHasExitCode = hasExitCode(defaultEval);
+    mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block;
+    bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval);
     bool hasAnyExitCode = defaultHasExitCode;
     if (!hasAnyExitCode)
       for (auto label : labelList)
         if (label && hasExitCode(evalOfLabel(label))) {
           hasAnyExitCode = true;
           break;
         }
     mlir::Location loc = toLocation();
     size_t branchCount = labelList.size();
     if (!inArithmeticIfContext && !hasAnyExitCode &&
         !getEval().forceAsUnstructured()) { // from -no-structured-fir option
       // Generate a SelectOp.
       llvm::SmallVector<mlir::Block *> blockList;
       for (auto label : labelList) {
         mlir::Block *block =
             label ? evalOfLabel(label).block : defaultEval.block;
         assert(block && "missing multiway branch block");
         blockList.push_back(block);
       }
-      blockList.push_back(defaultEval.block);
+      blockList.push_back(defaultBlock);
       if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks.
         std::swap(blockList[branchCount - 1], blockList[branchCount]);
       builder->create<fir::SelectOp>(loc, selector, valueList, blockList);
       return;
     }
     mlir::Type selectorType = selector.getType();
     bool realSelector = selectorType.isa<mlir::FloatType>();
     assert((inArithmeticIfContext || !realSelector) && "invalid selector type");
for (auto label : llvm::enumerate(labelList)) {
         cond = builder->create<mlir::arith::CmpIOp>(
             loc,
             valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne
                                           : mlir::arith::CmpIPredicate::eq,
             selector,
             builder->createIntegerConstant(loc, selectorType,
                                            valueList[label.index()]));
       // Branch to a new block with exit code and then to the target, or branch
-      // directly to the target. defaultEval is the "else" target.
+      // directly to the target. defaultBlock is the "else" target.
       bool lastBranch = label.index() == branchCount - 1;
       mlir::Block *nextBlock =
           lastBranch && !defaultHasExitCode
-              ? defaultEval.block
+              ? defaultBlock
               : builder->getBlock()->splitBlock(builder->getInsertionPoint());
       const Fortran::lower::pft::Evaluation &targetEval =
           label.value() ? evalOfLabel(label.value()) : defaultEval;
       if (hasExitCode(targetEval)) {
         mlir::Block *jumpBlock =
             builder->getBlock()->splitBlock(builder->getInsertionPoint());
         genConditionalBranch(cond, jumpBlock, nextBlock);
         startBlock(jumpBlock);
void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
     const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
         getEval().getOwningProcedure()->labelEvaluationMap;
     const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t));
     assert(iter != labelEvaluationMap.end() && "label missing from map");
     genMultiwayBranch(expr, valueList, labelList, *iter->second);
   }
 
   void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
-    // Program requirement 1990 8.2.4 -
-    //
-    //   At the time of execution of an assigned GOTO statement, the integer
-    //   variable must be defined with the value of a statement label of a
-    //   branch target statement that appears in the same scoping unit.
-    //   Note that the variable may be defined with a statement label value
-    //   only by an ASSIGN statement in the same scoping unit as the assigned
-    //   GOTO statement.
-
+    // See Fortran 90 Clause 8.2.4.
+    // Relax the requirement that the GOTO variable must have a value in the
+    // label list when a list is present, and allow a branch to any non-format
+    // target that has an ASSIGN statement for the variable.
     mlir::Location loc = toLocation();
     Fortran::lower::pft::Evaluation &eval = getEval();
+    Fortran::lower::pft::FunctionLikeUnit &owningProc =
+        *eval.getOwningProcedure();
     const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
-        eval.getOwningProcedure()->assignSymbolLabelMap;
+        owningProc.assignSymbolLabelMap;
+    const Fortran::lower::pft::LabelEvalMap &labelEvalMap =
+        owningProc.labelEvaluationMap;
     const Fortran::semantics::Symbol &symbol =
         *std::get<Fortran::parser::Name>(stmt.t).symbol;
-    auto selectExpr =
-        builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
-    auto iter = symbolLabelMap.find(symbol);
-    if (iter == symbolLabelMap.end()) {
-      // Fail for a nonconforming program unit that does not have any ASSIGN
-      // statements. The front end should check for this.
-      mlir::emitError(loc, "(semantics issue) no assigned goto targets");
-      exit(1);
-    }
-    auto labelSet = iter->second;
+    auto labelSetIter = symbolLabelMap.find(symbol);
     llvm::SmallVector<int64_t> valueList;
     llvm::SmallVector<Fortran::parser::Label> labelList;
-    // Add labels from an explicit list. The list may have duplicates.
-    for (Fortran::parser::Label label :
-         std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
-      // Ignore duplicates.
-      if (labelSet.count(label) && !llvm::is_contained(labelList, label)) {
-        valueList.push_back(label); // label as an integer
+    if (labelSetIter != symbolLabelMap.end()) {
+      for (auto &label : labelSetIter->second) {
+        const auto evalIter = labelEvalMap.find(label);
+        assert(evalIter != labelEvalMap.end() && "assigned goto label missing");
+        if (evalIter->second->block) { // non-format statement
+          valueList.push_back(label);  // label as an integer
           labelList.push_back(label);
         }
       }
-    // Absent an explicit list, add all possible label targets.
-    if (labelList.empty())
-      for (auto &label : labelSet) {
-        valueList.push_back(label); // label as an integer
-        labelList.push_back(label);
-      }
-    // Add a nop/fallthrough branch for a nonconforming program.
-    genMultiwayBranch(selectExpr, valueList, labelList, eval.nonNopSuccessor());
+    if (!labelList.empty()) {
+      auto selectExpr =
+          builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
+      // Add a default error target in case the goto is nonconforming.
+      mlir::Block *errorBlock =
+          builder->getBlock()->splitBlock(builder->getInsertionPoint());
+      genMultiwayBranch(selectExpr, valueList, labelList,
+                        eval.nonNopSuccessor(), errorBlock);
+      startBlock(errorBlock);
+    }
+    fir::runtime::genReportFatalUserError(
+        *builder, loc,
+        "Assigned GOTO variable '" + symbol.name().ToString() +
+            "' does not have a valid target label value");
+    builder->create<fir::UnreachableOp>(loc);
   }
 
   /// Collect DO CONCURRENT or FORALL loop control information.
   IncrementLoopNestInfo getConcurrentControl(
       const Fortran::parser::ConcurrentHeader &header,
       const std::list<Fortran::parser::LocalitySpec> &localityList = {}) {
     IncrementLoopNestInfo incrementLoopNestInfo;
     for (const Fortran::parser::ConcurrentControl &control :

flang/test/Lower/assigned-goto.f90

 ! RUN: bbc -emit-fir -o - %s | FileCheck %s
 
   ! CHECK-LABEL: func @_QPnolist
   subroutine nolist
     integer L, V
  11 V = 1
     ! CHECK: fir.store %c31{{.*}} to %{{.}}
     assign 31 to L
     ! CHECK: fir.select %{{.}} : i32 [31, ^bb{{.}}, unit, ^bb{{.}}]
+    ! CHECK: fir.call @_FortranAReportFatalUserError
     goto L ! no list
  21 V = 2
     go to 41
  31 V = 3
  41 print*, 3, V
  end
 
  ! CHECK-LABEL: func @_QPlist
  subroutine list
-    integer L, V
+    integer L, L1, V
+ 66 format("Nonsense")
+    assign 66 to L
+    assign 42 to L1
     ! CHECK: fir.store %c22{{.*}} to %{{.}}
     assign 22 to L
  12 V = 100
     ! CHECK: fir.store %c32{{.*}} to %{{.}}
     assign 32 to L
-    ! CHECK: fir.select %{{.}} : i32 [32, ^bb{{.}}, 22, ^bb{{.}}, unit, ^bb{{.}}]
+    ! CHECK: fir.select %{{.}} : i32 [22, ^bb{{.}}, 32, ^bb{{.}}, unit, ^bb{{.}}]
+    ! CHECK: fir.call @_FortranAReportFatalUserError
     goto L (42, 32, 22, 32, 32) ! duplicate labels are allowed
  22 V = 200
     go to 42
  32 V = 300
  42 print*, 300, V
  end
 
     call nolist
     call list
  end