[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

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

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_; }
+  bool isAlternateReturn() const {
-  void set_isAlternateReturn() { isAlternateReturn_ = true; }
+    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};
 };

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.

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_ &&
+  return keyword_ == that.keyword_ && isPassedObject_ == that.isPassedObject_ &&
-      isAlternateReturn_ == that.isAlternateReturn_ &&
+      u_ == that.u_;
-      isPassedObject_ == that.isPassedObject_ && u_ == that.u_;
 }
 
 void ActualArgument::Parenthesize() {

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_) {
+  std::visit(
-    o << '*';
+      common::visitors{
-  }
+          [&](const common::CopyableIndirection<Expr<SomeType>> &expr) {
-  if (const auto *expr{UnwrapExpr()}) {
+            expr.value().AsFortran(o);
-    return expr->AsFortran(o);
+          },
-  } else {
+          [&](const AssumedType &assumedType) { assumedType.AsFortran(o); },
-    return std::get<AssumedType>(u_).AsFortran(o);
+          [&](const common::Label &label) { o << '*' << label; },
-  }
+      },
+      u_);
+  return o;
 }
 
 llvm::raw_ostream &SpecificIntrinsic::AsFortran(llvm::raw_ostream &o) const {

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);

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{
+        bool hasAlternateReturns{HasAlternateReturns(callee->arguments)};
-            callee->arguments.size() < actualArgList.size()};
         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;
   }
 }

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