From ae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6 Mon Sep 17 00:00:00 2001 From: Peter Steinfeld Date: Mon, 4 Jan 2021 09:35:15 -0800 Subject: [PATCH] [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 | 3 +++ flang/include/flang/Evaluate/call.h | 14 ++++++++++---- flang/include/flang/Parser/parse-tree.h | 2 +- flang/lib/Evaluate/call.cpp | 7 ++++--- flang/lib/Evaluate/formatting.cpp | 19 +++++++++++-------- flang/lib/Semantics/check-call.cpp | 2 +- flang/lib/Semantics/expression.cpp | 20 ++++++++++++++------ flang/test/Semantics/altreturn06.f90 | 16 ++++++++++++++++ 8 files changed, 60 insertions(+), 23 deletions(-) create mode 100644 flang/test/Semantics/altreturn06.f90 diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h index 5d5ab324e826..f0b111a3fec7 100644 --- 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 71e061054928..0e78839b2ccc 100644 --- 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 &&); explicit ActualArgument(common::CopyableIndirection> &&); explicit ActualArgument(AssumedType); + explicit ActualArgument(common::Label); ~ActualArgument(); ActualArgument &operator=(Expr &&); @@ -101,6 +103,8 @@ public: } } + common::Label GetLabel() const { return std::get(u_); } + std::optional GetType() const; int Rank() const; bool operator==(const ActualArgument &) const; @@ -108,8 +112,9 @@ public: std::optional 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(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>, AssumedType> u_; + std::variant>, AssumedType, + common::Label> + u_; std::optional 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 119a92bee211..7a7b2a184004 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -333,7 +333,7 @@ using ScalarDefaultCharExpr = Scalar; using ScalarDefaultCharConstantExpr = Scalar>; // 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 b4cf0dc3af3a..3fe56ab4874b 100644 --- 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 &&x) : u_{std::move(x)} {} ActualArgument::ActualArgument(common::CopyableIndirection> &&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 e59e79873f4c..df3671a919b5 100644 --- 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(u_).AsFortran(o); - } + std::visit( + common::visitors{ + [&](const common::CopyableIndirection> &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 959ad3384f61..0c1de4a1c093 100644 --- 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 0241d1ff030c..a4961af71bbc 100644 --- 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(&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 actual; - bool isAltReturn{false}; std::visit(common::visitors{ [&](const common::Indirection &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 index 000000000000..27a7b9a04540 --- /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