diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -190,8 +190,10 @@ 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 @@ std::optional> 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 class FunctionRef : public ProcedureRef { diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -100,6 +100,7 @@ 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, diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2006,7 +2006,8 @@ 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>(call.t)) { + const auto &actualArgList{std::get>(call.t)}; + for (const auto &arg : actualArgList) { analyzer.Analyze(arg, true /* is subroutine call */); } if (!analyzer.fatalErrors()) { @@ -2016,8 +2017,10 @@ ProcedureDesignator *proc{std::get_if(&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 @@ // be detected and represented (they're not expressions). // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed. std::optional actual; + bool isAltReturn{false}; std::visit(common::visitors{ [&](const common::Indirection &x) { // TODO: Distinguish & handle procedure name and @@ -2690,6 +2694,7 @@ "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 @@ actual->set_keyword(argKW->v.source); } actuals_.emplace_back(std::move(*actual)); - } else { + } else if (!isAltReturn) { fatalErrors_ = true; } } diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1292,4 +1292,13 @@ .Attach(constructLocation, GetEnclosingConstructMsg()); } +bool HasAlternateReturns(const Symbol &subprogram) { + for (const auto *dummyArg : subprogram.get().dummyArgs()) { + if (!dummyArg) { + return true; + } + } + return false; +} + } // namespace Fortran::semantics diff --git a/flang/test/Semantics/label01.F90 b/flang/test/Semantics/label01.F90 --- a/flang/test/Semantics/label01.F90 +++ b/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)