summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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
View Lorry Controller Status