summaryrefslogtreecommitdiff
path: root/flang
diff options
context:
space:
mode:
authorPeter Steinfeld <psteinfeld@nvidia.com>2021-01-04 09:35:15 -0800
committerPeter Steinfeld <psteinfeld@nvidia.com>2021-01-08 10:14:21 -0800
commitae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6 (patch)
tree9a63c5970ebac51a67c4a6138bcffe1035aa90bb /flang
parent311b247c9fb58ee476184a7eb8044b8f54f95035 (diff)
downloadllvm-ae0d1d2e5cd3a99da0b2eefc27c8f94b95f03cc6.tar.gz
[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
Diffstat (limited to 'flang')
-rw-r--r--flang/include/flang/Common/Fortran.h3
-rw-r--r--flang/include/flang/Evaluate/call.h14
-rw-r--r--flang/include/flang/Parser/parse-tree.h2
-rw-r--r--flang/lib/Evaluate/call.cpp7
-rw-r--r--flang/lib/Evaluate/formatting.cpp19
-rw-r--r--flang/lib/Semantics/check-call.cpp2
-rw-r--r--flang/lib/Semantics/expression.cpp20
-rw-r--r--flang/test/Semantics/altreturn06.f9016
8 files changed, 60 insertions, 23 deletions
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<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);
+ explicit ActualArgument(common::Label);
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
@@ -101,6 +103,8 @@ public:
}
}
+ 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 @@ public:
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 @@ 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<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