[flang] Add more support for alternate returns

Add `hasAlternateReturns` to `evaluate::ProcedureRef`.

Add `HasAlternateReturns` to test subprogram symbols.

Fix `label01.F90` test: It was checking that "error: " didn't appear in
the output. But that was erroneously matching a warning that ends
"would be in error:". So change it to check for ": error: " instead.

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

flang/include/flang/Evaluate/call.h

@@ -190,8 +190,10 @@ struct ProcedureDesignator {
 class ProcedureRef {
 public:
   CLASS_BOILERPLATE(ProcedureRef)
-  ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a)
-      : proc_{std::move(p)}, arguments_(std::move(a)) {}
+  ProcedureRef(ProcedureDesignator &&p, ActualArguments &&a,
+      bool hasAlternateReturns = false)
+      : proc_{std::move(p)}, arguments_{std::move(a)},
+        hasAlternateReturns_{hasAlternateReturns} {}
   ~ProcedureRef();
 
   ProcedureDesignator &proc() { return proc_; }
@@ -202,12 +204,14 @@ public:
   std::optional<Expr<SubscriptInteger>> LEN() const;
   int Rank() const;
   bool IsElemental() const { return proc_.IsElemental(); }
+  bool hasAlternateReturns() const { return hasAlternateReturns_; }
   bool operator==(const ProcedureRef &) const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
 protected:
   ProcedureDesignator proc_;
   ActualArguments arguments_;
+  bool hasAlternateReturns_;
 };
 
 template <typename A> class FunctionRef : public ProcedureRef {

flang/include/flang/Semantics/tools.h

@@ -100,6 +100,7 @@ bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
 bool IsAutomatic(const Symbol &);
+bool HasAlternateReturns(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,

flang/lib/Semantics/expression.cpp

@@ -2006,7 +2006,8 @@ void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
   const parser::Call &call{callStmt.v};
   auto restorer{GetContextualMessages().SetLocation(call.source)};
   ArgumentAnalyzer analyzer{*this, call.source, true /* allowAssumedType */};
-  for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
+  const auto &actualArgList{std::get<std::list<parser::ActualArgSpec>>(call.t)};
+  for (const auto &arg : actualArgList) {
     analyzer.Analyze(arg, true /* is subroutine call */);
   }
   if (!analyzer.fatalErrors()) {
@@ -2016,8 +2017,10 @@ void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
       ProcedureDesignator *proc{std::get_if<ProcedureDesignator>(&callee->u)};
       CHECK(proc);
       if (CheckCall(call.source, *proc, callee->arguments)) {
-        callStmt.typedCall.reset(
-            new ProcedureRef{std::move(*proc), std::move(callee->arguments)});
+        bool hasAlternateReturns{
+            analyzer.GetActuals().size() < actualArgList.size()};
+        callStmt.typedCall.reset(new ProcedureRef{std::move(*proc),
+            std::move(callee->arguments), hasAlternateReturns});
       }
     }
   }
@@ -2678,6 +2681,7 @@ 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
@@ -2690,6 +2694,7 @@ void ArgumentAnalyzer::Analyze(
                          "alternate return specification may not appear on"
                          " function reference"_err_en_US);
                    }
+                   isAltReturn = true;
                  },
                  [&](const parser::ActualArg::PercentRef &) {
                    context_.Say("TODO: %REF() argument"_err_en_US);
@@ -2704,7 +2709,7 @@ void ArgumentAnalyzer::Analyze(
       actual->set_keyword(argKW->v.source);
     }
     actuals_.emplace_back(std::move(*actual));
-  } else {
+  } else if (!isAltReturn) {
     fatalErrors_ = true;
   }
 }

flang/lib/Semantics/tools.cpp

@@ -1292,4 +1292,13 @@ void LabelEnforce::SayWithConstruct(SemanticsContext &context,
       .Attach(constructLocation, GetEnclosingConstructMsg());
 }
 
+bool HasAlternateReturns(const Symbol &subprogram) {
+  for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) {
+    if (!dummyArg) {
+      return true;
+    }
+  }
+  return false;
+}
+
 } // namespace Fortran::semantics

flang/test/Semantics/label01.F90

@@ -1,13 +1,12 @@
 ! RUN: %f18 -funparse-with-symbols -DSTRICT_F18 -Mstandard %s 2>&1 | FileCheck %s
 ! RUN: %f18 -funparse-with-symbols -DARCHAIC_FORTRAN %s 2>&1 | FileCheck %s
-! CHECK-NOT: error:{{[[:space:]]}}
+! CHECK-NOT: :{{[[:space:]]}}error:{{[[:space:]]}}
 ! FIXME: the above check line does not work because diags are not emitted with error: in them.
 
 ! these are the conformance tests
 ! define STRICT_F18 to eliminate tests of features not in F18
 ! define ARCHAIC_FORTRAN to add test of feature found in Fortran before F95
 
-
 subroutine sub00(a,b,n,m)
   integer :: n, m
   real a(n)