[flang] Fix bogus message on internal subprogram with alternate return

Internal subprograms have explicit interfaces.  If an internal subprogram has
an alternate return, we check its explicit interface.  But we were not
putting the label values of alternate returns into the actual argument.

I fixed this by changing the definition of actual arguments to be able
to contain a common::Label and putting the label for an alternate return
into the actual argument.

I also verified that we were already doing all of the semantic checking
required for alternate returns and removed a "TODO" for this.

I also added the test altreturn06.f90.

Differential Revision: https://reviews.llvm.org/D94017

diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h
index 5d5ab32..f0b111a 100644 (file)
--- a/flang/include/flang/Common/Fortran.h
+++ b/flang/include/flang/Common/Fortran.h
@@ -67,6 +67,9 @@ enum class RoundingMode : std::uint8_t {
   TiesAwayFromZero, // ROUND=COMPATIBLE, RC - ties round away from zero
 };
 
+// Fortran label. Must be in [1..99999].
+using Label = std::uint64_t;
+
 // Fortran arrays may have up to 15 dimensions (See Fortran 2018 section 5.4.6).
 static constexpr int maxRank{15};
 } // namespace Fortran::common

diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index 71e0610..0e78839 100644 (file)
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -13,6 +13,7 @@
 #include "constant.h"
 #include "formatting.h"
 #include "type.h"
+#include "flang/Common/Fortran.h"
 #include "flang/Common/indirection.h"
 #include "flang/Common/reference.h"
 #include "flang/Parser/char-block.h"
@@ -73,6 +74,7 @@ public:
   explicit ActualArgument(Expr<SomeType> &&);
   explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
   explicit ActualArgument(AssumedType);
+  explicit ActualArgument(common::Label);
   ~ActualArgument();
   ActualArgument &operator=(Expr<SomeType> &&);
 
@@ -101,6 +103,8 @@ public:
     }
   }
 
+  common::Label GetLabel() const { return std::get<common::Label>(u_); }
+
   std::optional<DynamicType> GetType() const;
   int Rank() const;
   bool operator==(const ActualArgument &) const;
@@ -108,8 +112,9 @@ public:
 
   std::optional<parser::CharBlock> keyword() const { return keyword_; }
   void set_keyword(parser::CharBlock x) { keyword_ = x; }
-  bool isAlternateReturn() const { return isAlternateReturn_; }
-  void set_isAlternateReturn() { isAlternateReturn_ = true; }
+  bool isAlternateReturn() const {
+    return std::holds_alternative<common::Label>(u_);
+  }
   bool isPassedObject() const { return isPassedObject_; }
   void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; }
 
@@ -131,9 +136,10 @@ private:
   // e.g. between X and (X).  The parser attempts to parse each argument
   // first as a variable, then as an expression, and the distinction appears
   // in the parse tree.
-  std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType> u_;
+  std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType,
+      common::Label>
+      u_;
   std::optional<parser::CharBlock> keyword_;
-  bool isAlternateReturn_{false}; // whether expr is a "*label" number
   bool isPassedObject_{false};
   common::Intent dummyIntent_{common::Intent::Default};
 };

diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 119a92b..7a7b2a1 100644 (file)
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -333,7 +333,7 @@ using ScalarDefaultCharExpr = Scalar<DefaultCharExpr>;
 using ScalarDefaultCharConstantExpr = Scalar<DefaultChar<ConstantExpr>>;
 
 // R611 label -> digit [digit]...
-using Label = std::uint64_t; // validated later, must be in [1..99999]
+using Label = common::Label; // validated later, must be in [1..99999]
 
 // A wrapper for xzy-stmt productions that are statements, so that
 // source provenances and labels have a uniform representation.

diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp
index b4cf0dc..3fe56ab 100644 (file)
--- a/flang/lib/Evaluate/call.cpp
+++ b/flang/lib/Evaluate/call.cpp
@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/call.h"
+#include "flang/Common/Fortran.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/characteristics.h"
 #include "flang/Evaluate/expression.h"
@@ -20,6 +21,7 @@ ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {}
 ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)
     : u_{std::move(v)} {}
 ActualArgument::ActualArgument(AssumedType x) : u_{x} {}
+ActualArgument::ActualArgument(common::Label x) : u_{x} {}
 ActualArgument::~ActualArgument() {}
 
 ActualArgument::AssumedType::AssumedType(const Symbol &symbol)
@@ -54,9 +56,8 @@ int ActualArgument::Rank() const {
 }
 
 bool ActualArgument::operator==(const ActualArgument &that) const {
-  return keyword_ == that.keyword_ &&
-      isAlternateReturn_ == that.isAlternateReturn_ &&
-      isPassedObject_ == that.isPassedObject_ && u_ == that.u_;
+  return keyword_ == that.keyword_ && isPassedObject_ == that.isPassedObject_ &&
+      u_ == that.u_;
 }
 
 void ActualArgument::Parenthesize() {

diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index e59e798..df3671a 100644 (file)
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/formatting.h"
+#include "flang/Common/Fortran.h"
 #include "flang/Evaluate/call.h"
 #include "flang/Evaluate/constant.h"
 #include "flang/Evaluate/expression.h"
@@ -108,14 +109,16 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
   if (keyword_) {
     o << keyword_->ToString() << '=';
   }
-  if (isAlternateReturn_) {
-    o << '*';
-  }
-  if (const auto *expr{UnwrapExpr()}) {
-    return expr->AsFortran(o);
-  } else {
-    return std::get<AssumedType>(u_).AsFortran(o);
-  }
+  std::visit(
+      common::visitors{
+          [&](const common::CopyableIndirection<Expr<SomeType>> &expr) {
+            expr.value().AsFortran(o);
+          },
+          [&](const AssumedType &assumedType) { assumedType.AsFortran(o); },
+          [&](const common::Label &label) { o << '*' << label; },
+      },
+      u_);
+  return o;
 }
 
 llvm::raw_ostream &SpecificIntrinsic::AsFortran(llvm::raw_ostream &o) const {

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 959ad33..0c1de4a 100644 (file)
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -647,7 +647,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
             CheckProcedureArg(arg, proc, dummyName, context);
           },
           [&](const characteristics::AlternateReturn &) {
-            // TODO check alternate return
+            // All semantic checking is done elsewhere
           },
       },
       dummy.u);

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 0241d1f..a4961af 100644 (file)
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -10,6 +10,7 @@
 #include "check-call.h"
 #include "pointer-assignment.h"
 #include "resolve-names.h"
+#include "flang/Common/Fortran.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/common.h"
 #include "flang/Evaluate/fold.h"
@@ -2129,6 +2130,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
   return std::nullopt;
 }
 
+static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
+  for (const auto &arg : args) {
+    if (arg && arg->isAlternateReturn()) {
+      return true;
+    }
+  }
+  return false;
+}
+
 void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
   const parser::Call &call{callStmt.v};
   auto restorer{GetContextualMessages().SetLocation(call.source)};
@@ -2144,8 +2154,7 @@ void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
       ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
       CHECK(proc);
       if (CheckCall(call.source, *proc, callee->arguments)) {
-        bool hasAlternateReturns{
-            callee->arguments.size() < actualArgList.size()};
+        bool hasAlternateReturns{HasAlternateReturns(callee->arguments)};
         callStmt.typedCall.Reset(
             new ProcedureRef{std::move(*proc), std::move(callee->arguments),
                 hasAlternateReturns},
@@ -2851,20 +2860,19 @@ void ArgumentAnalyzer::Analyze(
   // be detected and represented (they're not expressions).
   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
   std::optional<ActualArgument> actual;
-  bool isAltReturn{false};
   std::visit(common::visitors{
                  [&](const common::Indirection<parser::Expr> &x) {
                    // TODO: Distinguish & handle procedure name and
                    // proc-component-ref
                    actual = AnalyzeExpr(x.value());
                  },
-                 [&](const parser::AltReturnSpec &) {
+                 [&](const parser::AltReturnSpec &label) {
                    if (!isSubroutine) {
                      context_.Say(
                          "alternate return specification may not appear on"
                          " function reference"_err_en_US);
                    }
-                   isAltReturn = true;
+                   actual = ActualArgument(label.v);
                  },
                  [&](const parser::ActualArg::PercentRef &) {
                    context_.Say("TODO: %REF() argument"_err_en_US);
@@ -2879,7 +2887,7 @@ void ArgumentAnalyzer::Analyze(
       actual->set_keyword(argKW->v.source);
     }
     actuals_.emplace_back(std::move(*actual));
-  } else if (!isAltReturn) {
+  } else {
     fatalErrors_ = true;
   }
 }

diff --git a/flang/test/Semantics/altreturn06.f90 b/flang/test/Semantics/altreturn06.f90
new file mode 100644 (file)
index 0000000..27a7b9a
--- /dev/null
+++ b/flang/test/Semantics/altreturn06.f90
@@ -0,0 +1,16 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Test alternat return argument passing for internal and external subprograms
+! Both of the following are OK
+  call extSubprogram (*100)
+  call intSubprogram (*100)
+  call extSubprogram (*101)
+  call intSubprogram (*101)
+100 PRINT *,'First alternate return'
+!ERROR: Label '101' is not a branch target
+!ERROR: Label '101' is not a branch target
+101 FORMAT("abc")
+contains
+  subroutine intSubprogram(*)
+    return(1)
+  end subroutine
+end