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
#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"
explicit ActualArgument(Expr<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);
+ explicit ActualArgument(common::Label);
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
}
}
+ common::Label GetLabel() const { return std::get<common::Label>(u_); }
+
std::optional<DynamicType> GetType() const;
int Rank() const;
bool operator==(const ActualArgument &) const;
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; }
// 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};
};
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.
//===----------------------------------------------------------------------===//
#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"
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)
}
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() {
//===----------------------------------------------------------------------===//
#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"
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 {
CheckProcedureArg(arg, proc, dummyName, context);
},
[&](const characteristics::AlternateReturn &) {
- // TODO check alternate return
+ // All semantic checking is done elsewhere
},
},
dummy.u);
#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"
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)};
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},
// 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);
actual->set_keyword(argKW->v.source);
}
actuals_.emplace_back(std::move(*actual));
- } else if (!isAltReturn) {
+ } else {
fatalErrors_ = true;
}
}
--- /dev/null
+! 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