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

[PeteSteinfeld]

Summary

Internal subprograms have explicit interfaces. If an internal subprogram has
an alternate return, we check its explicit interface. But our explicit
interface checking was not allowing for alternate returns.

I fixed this by checking to see if the dummy argument was an alternate return.
I also added the test altreturn06.f90.

[klausler]

I'm confused by this change. The call checking code that's been modified pertains to absent actual arguments; but alternate returns can't be optional and must have corresponding positional actual arguments.

[PeteSteinfeld]

In D94017#2477542, @klausler wrote:

I'm confused by this change. The call checking code that's been modified pertains to absent actual arguments; but alternate returns can't be optional and must have corresponding positional actual arguments.

The code is checking for how to handle the situation where the actual argument is missing. That's potentially the case for optional arguments, but it also happens for alternate returns. So new code is saying that it's OK for the actual argument to be missing if the dummy argument is an alternate return. Formerly, we emitted an error message when calling an internal subprogram with alternate returns.

[klausler]

In D94017#2477615, @PeteSteinfeld wrote:

In D94017#2477542, @klausler wrote:

I'm confused by this change. The call checking code that's been modified pertains to absent actual arguments; but alternate returns can't be optional and must have corresponding positional actual arguments.

The code is checking for how to handle the situation where the actual argument is missing. That's potentially the case for optional arguments, but it also happens for alternate returns. So new code is saying that it's OK for the actual argument to be missing if the dummy argument is an alternate return. Formerly, we emitted an error message when calling an internal subprogram with alternate returns.

But how can it be okay for the actual argument to be missing when the corresponding dummy argument is an alternate return?

[PeteSteinfeld]

But how can it be okay for the actual argument to be missing when the corresponding dummy argument is an alternate return?

I don't know. I'll investigate further ...

[PeteSteinfeld]

With Peter's guidance, I changed the definition of actual arguments to allow
for the value of a statement label and changed the code that processes actual
arguments to put the value of the label into the actual argument.

I also verified that we were already doing the semantic checking required for
alternate returns and added another test.

[klausler]

flang/lib/Semantics/expression.cpp

2868

This variable, and the code later that it enables, may no longer be needed; I'm not sure why it's there.

[PeteSteinfeld]

flang/lib/Semantics/expression.cpp

2868

It does seem wrong to create data that's never used.

@schweitz, as I understand things, the current lowering code gets the value of alternate return labels from the parse tree. Do you plan to change that once their available in the values of the ActualArgument?

Note that there are a couple of ways that this value is used. One is for the implementation of the function isAlternateReturn(). The other is that you can now dump out the value of the label in the actual argument if you dump it out.

[jeanPerier]

@schweitz, as I understand things, the current lowering code gets the value of alternate return labels from the parse tree. Do you plan to change that once their available in the values of the ActualArgument?

That would make sens IMHO.
Otherwise, the change you have should work OK with lowering, except for the ProcedureRef hasAlternateReturns that is now wrong and would make lowering fail (see inlined comment).

flang/include/flang/Evaluate/call.h

19

parse-tree.h is pretty big, have you seen any compile time increase with this include here ? If so, you could define Label in lib/Common/Fortran.h and use that here and in parse-tree.h to save the parse-tree.h include here.

flang/lib/Semantics/expression.cpp

2148

That part of the code is now wrong (since argument list now contains the labels). This will yield wrong lowering. You could replace it with a call to a helper like:

static bool HasAlternateReturns(const evaluate::ActualArguments &args) {
  for (const auto &arg : args) {
    if (arg && arg->isAlternateReturn()) {
      return true;
    }
  }
  return false;
}

and bool hasAlternateReturns{HasAlternateReturns(callee->arguments)};

2868

I also think isAltReturn is made useless by this change and could be removed.

[PeteSteinfeld]

Responding to Jean's comments.

[schweitz]

flang/lib/Semantics/expression.cpp

2148

Let me know if you'd like Val to look at this one, Jean.

[PeteSteinfeld]

flang/include/flang/Evaluate/call.h

19

Thanks, Jean. I'll do that.

[jeanPerier]

Looks good to me, thanks Pete.

flang/include/flang/Evaluate/call.h

 
 #include "common.h"
 #include "constant.h"
 #include "formatting.h"
 #include "type.h"
 #include "flang/Common/indirection.h"
 #include "flang/Common/reference.h"
 #include "flang/Parser/char-block.h"
+#include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/attr.h"
 #include <optional>
 #include <vector>
 
 namespace llvm {
 class raw_ostream;
 }
 
public:
   private:
     SymbolRef symbol_;
   };
 
   DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
   explicit ActualArgument(Expr<SomeType> &&);
   explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
   explicit ActualArgument(AssumedType);
+  explicit ActualArgument(parser::Label);
   ~ActualArgument();
   ActualArgument &operator=(Expr<SomeType> &&);
 
   Expr<SomeType> *UnwrapExpr() {
     if (auto *p{
             std::get_if<common::CopyableIndirection<Expr<SomeType>>>(&u_)}) {
       return &p->value();
     } else {
public:
 
   std::optional<DynamicType> GetType() const;
   int Rank() const;
   bool operator==(const ActualArgument &) const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
   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<parser::Label>(u_);
+  }
   bool isPassedObject() const { return isPassedObject_; }
   void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; }
 
   bool Matches(const characteristics::DummyArgument &) const;
   common::Intent dummyIntent() const { return dummyIntent_; }
   ActualArgument &set_dummyIntent(common::Intent intent) {
     dummyIntent_ = intent;
     return *this;
   }
 
   // Wrap this argument in parentheses
   void Parenthesize();
 
   // TODO: Mark legacy %VAL and %REF arguments
 
 private:
   // Subtlety: There is a distinction that must be maintained here between an
   // actual argument expression that is a variable and one that is not,
   // 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,
+      parser::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};
 };
 
 using ActualArguments = std::vector<std::optional<ActualArgument>>;
 
 // Intrinsics are identified by their names and the characteristics
 // of their arguments, at least for now.

flang/lib/Evaluate/call.cpp

 
 namespace Fortran::evaluate {
 
 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
 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(parser::Label x) : u_{x} {}
 ActualArgument::~ActualArgument() {}
 
 ActualArgument::AssumedType::AssumedType(const Symbol &symbol)
     : symbol_{symbol} {
   const semantics::DeclTypeSpec *type{symbol.GetType()};
   CHECK(type && type->category() == semantics::DeclTypeSpec::TypeStar);
 }
 
int ActualArgument::Rank() const {
   if (const Expr<SomeType> *expr{UnwrapExpr()}) {
     return expr->Rank();
   } else {
     return std::get<AssumedType>(u_).Rank();
   }
 }
 
 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() {
   u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));
 }
 
 SpecificIntrinsic::SpecificIntrinsic(
     IntrinsicProcedure n, characteristics::Procedure &&chars)

flang/lib/Evaluate/formatting.cpp

llvm::raw_ostream &ActualArgument::AssumedType::AsFortran(
     llvm::raw_ostream &o) const {
   return o << symbol_->name().ToString();
 }
 
 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 parser::Label &label) { o << '*' << label; },
+      },
+      u_);
+  return o;
 }
 
 llvm::raw_ostream &SpecificIntrinsic::AsFortran(llvm::raw_ostream &o) const {
   return o << name;
 }
 
 llvm::raw_ostream &ProcedureRef::AsFortran(llvm::raw_ostream &o) const {
   for (const auto &arg : arguments_) {

flang/lib/Semantics/check-call.cpp

std::visit(
                 }
               }
             }
           },
           [&](const characteristics::DummyProcedure &proc) {
             CheckProcedureArg(arg, proc, dummyName, context);
           },
           [&](const characteristics::AlternateReturn &) {
-            // TODO check alternate return
+            // All semantic checking is done elsewhere
           },
       },
       dummy.u);
 }
 
 static void RearrangeArguments(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
   CHECK(proc.HasExplicitInterface());

flang/lib/Semantics/expression.cpp

void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
   if (!analyzer.fatalErrors()) {
     if (std::optional<CalleeAndArguments> callee{
             GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
                 analyzer.GetActuals(), true /* subroutine */)}) {
       ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
       CHECK(proc);
       if (CheckCall(call.source, *proc, callee->arguments)) {
         bool hasAlternateReturns{
             callee->arguments.size() < actualArgList.size()};
         callStmt.typedCall.Reset(
             new ProcedureRef{std::move(*proc), std::move(callee->arguments),
                 hasAlternateReturns},
             ProcedureRef::Deleter);
       }
     }
   }
 }
void ArgumentAnalyzer::Analyze(
   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 &x) {
                    if (!isSubroutine) {
                      context_.Say(
                          "alternate return specification may not appear on"
                          " function reference"_err_en_US);
                    }
+                   actual = ActualArgument(x.v);
                    isAltReturn = true;
                  },
                  [&](const parser::ActualArg::PercentRef &) {
                    context_.Say("TODO: %REF() argument"_err_en_US);
                  },
                  [&](const parser::ActualArg::PercentVal &) {
                    context_.Say("TODO: %VAL() argument"_err_en_US);
                  },
              },

flang/test/Semantics/altreturn06.f90

+! 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