[llvm-branch-commits] [flang] ae0d1d2 - [flang] Fix bogus message on internal subprogram with alternate return
Peter Steinfeld via llvm-branch-commits
llvm-branch-commits at lists.llvm.org
Fri Jan 8 10:18:55 PST 2021
Author: Peter Steinfeld
Date: 2021-01-08T10:14:21-08:00
New Revision: ae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6
URL: https://github.com/llvm/llvm-project/commit/ae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6
DIFF: https://github.com/llvm/llvm-project/commit/ae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6.diff
LOG: [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
Added:
flang/test/Semantics/altreturn06.f90
Modified:
flang/include/flang/Common/Fortran.h
flang/include/flang/Evaluate/call.h
flang/include/flang/Parser/parse-tree.h
flang/lib/Evaluate/call.cpp
flang/lib/Evaluate/formatting.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/expression.cpp
Removed:
################################################################################
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 @@ class ActualArgument {
explicit ActualArgument(Expr<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);
+ explicit ActualArgument(common::Label);
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
@@ -101,6 +103,8 @@ class ActualArgument {
}
}
+ common::Label GetLabel() const { return std::get<common::Label>(u_); }
+
std::optional<DynamicType> GetType() const;
int Rank() const;
bool operator==(const ActualArgument &) const;
@@ -108,8 +112,9 @@ class ActualArgument {
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<common::Label>(u_);
+ }
bool isPassedObject() const { return isPassedObject_; }
void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; }
@@ -131,9 +136,10 @@ class ActualArgument {
// 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,
+ common::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};
};
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<DefaultCharExpr>;
using ScalarDefaultCharConstantExpr = Scalar<DefaultChar<ConstantExpr>>;
// 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<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(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<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 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<ProcedureDesignator>(&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<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 &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
More information about the llvm-branch-commits
mailing list