diff --git a/flang/include/flang/Common/Fortran.h b/flang/include/flang/Common/Fortran.h --- a/flang/include/flang/Common/Fortran.h +++ b/flang/include/flang/Common/Fortran.h @@ -67,6 +67,9 @@ 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 --- 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 @@ explicit ActualArgument(Expr &&); explicit ActualArgument(common::CopyableIndirection> &&); explicit ActualArgument(AssumedType); + explicit ActualArgument(common::Label); ~ActualArgument(); ActualArgument &operator=(Expr &&); @@ -101,6 +103,8 @@ } } + common::Label GetLabel() const { return std::get(u_); } + std::optional GetType() const; int Rank() const; bool operator==(const ActualArgument &) const; @@ -108,8 +112,9 @@ 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 @@ // 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 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -333,7 +333,7 @@ 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 --- 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(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 @@ } 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 --- 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 @@ 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 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -647,7 +647,7 @@ 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 --- 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 @@ 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 @@ 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 @@ // 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 @@ 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 --- /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