forked from OSchip/llvm-project
[flang] Resolve extended intrinsic operators
Enhance `ArgumentAnalyzer` to do most of the work for this. For each kind of operator that might have a user-defined form we follow this process: - analyze the arguments - if the types and shapes match the intrinsic operator do the usual processing - otherwise attempt to interpret it as a user-defined operator with `TryDefinedOp` When we fail to resolve an operator, produce different errors depending on whether there is a user-defined operator available or not. If there is, report that neither user-defined nor intrinsic operator worked. If there is not, describe the rules for the intrinsic operator. In either case, include the type(s) of the operand(s). Most of the uses of `ArgumentAnalyzer` are in helper functions that apply to classes of operators. For consistency, rename `BinaryOperationHelper` to `NumericBinaryOperator` and `LogicalHelper` to `LogicalBinaryHelper` and introduce `NumericUnaryHelper` for unary `+` and `-`. `.NOT.` and `//` are not implemented in helpers. Replace `success_` with `fatalErrors_` in `ArgumentAnalyzer` for consistency with `ExpressionAnalyzer`. Add `NumericOperator` and `LogicalOperator` enums to `Fortran.h` to go with `RelationalOperator`. Add `AddFortran` functions to each to convert to a Fortran source string. `RelationalOperator` also has `AllFortranNames` because there are multiple names for each operator. This replaces `LogicalOperator` in `expression.h` and the string representation of the operators in `formatting.cc`. Original-commit: flang-compiler/f18@3bb9d664e8 Reviewed-on: https://github.com/flang-compiler/f18/pull/807
This commit is contained in:
parent
41aa3bf7a4
commit
dce7f0aca0
|
@ -13,6 +13,7 @@
|
|||
# limitations under the License.
|
||||
|
||||
add_library(FortranCommon
|
||||
Fortran.cc
|
||||
default-kinds.cc
|
||||
idioms.cc
|
||||
)
|
||||
|
|
|
@ -0,0 +1,56 @@
|
|||
// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#include "Fortran.h"
|
||||
|
||||
namespace Fortran::common {
|
||||
|
||||
const char *AsFortran(NumericOperator opr) {
|
||||
switch (opr) {
|
||||
SWITCH_COVERS_ALL_CASES
|
||||
case NumericOperator::Power: return "**";
|
||||
case NumericOperator::Multiply: return "*";
|
||||
case NumericOperator::Divide: return "/";
|
||||
case NumericOperator::Add: return "+";
|
||||
case NumericOperator::Subtract: return "-";
|
||||
}
|
||||
}
|
||||
|
||||
const char *AsFortran(LogicalOperator opr) {
|
||||
switch (opr) {
|
||||
SWITCH_COVERS_ALL_CASES
|
||||
case LogicalOperator::And: return ".and.";
|
||||
case LogicalOperator::Or: return ".or.";
|
||||
case LogicalOperator::Eqv: return ".eqv.";
|
||||
case LogicalOperator::Neqv: return ".neqv.";
|
||||
}
|
||||
}
|
||||
|
||||
const char *AsFortran(RelationalOperator opr) {
|
||||
return *AllFortranNames(opr).begin();
|
||||
}
|
||||
|
||||
std::initializer_list<const char *> AllFortranNames(RelationalOperator opr) {
|
||||
switch (opr) {
|
||||
SWITCH_COVERS_ALL_CASES
|
||||
case RelationalOperator::LT: return {"<", ".lt."};
|
||||
case RelationalOperator::LE: return {"<=", ".le."};
|
||||
case RelationalOperator::EQ: return {"==", ".eq."};
|
||||
case RelationalOperator::NE: return {"/=", ".ne.", "<>"};
|
||||
case RelationalOperator::GE: return {">=", ".ge."};
|
||||
case RelationalOperator::GT: return {">", ".gt."};
|
||||
}
|
||||
}
|
||||
|
||||
}
|
|
@ -20,6 +20,7 @@
|
|||
|
||||
#include "idioms.h"
|
||||
#include <cinttypes>
|
||||
#include <initializer_list>
|
||||
|
||||
namespace Fortran::common {
|
||||
|
||||
|
@ -37,7 +38,16 @@ ENUM_CLASS(ImportKind, Default, Only, None, All)
|
|||
// The attribute on a type parameter can be KIND or LEN.
|
||||
ENUM_CLASS(TypeParamAttr, Kind, Len)
|
||||
|
||||
ENUM_CLASS(NumericOperator, Power, Multiply, Divide, Add, Subtract)
|
||||
const char *AsFortran(NumericOperator);
|
||||
|
||||
ENUM_CLASS(LogicalOperator, And, Or, Eqv, Neqv)
|
||||
const char *AsFortran(LogicalOperator);
|
||||
|
||||
ENUM_CLASS(RelationalOperator, LT, LE, EQ, NE, GE, GT)
|
||||
const char *AsFortran(RelationalOperator);
|
||||
// Map EQ to {"==", ".eq."}, for example.
|
||||
std::initializer_list<const char *> AllFortranNames(RelationalOperator);
|
||||
|
||||
ENUM_CLASS(Intent, Default, In, Out, InOut)
|
||||
|
||||
|
|
|
@ -41,6 +41,7 @@
|
|||
|
||||
namespace Fortran::evaluate {
|
||||
|
||||
using common::LogicalOperator;
|
||||
using common::RelationalOperator;
|
||||
|
||||
// Expressions are represented by specializations of the class template Expr.
|
||||
|
@ -388,8 +389,6 @@ struct Concat
|
|||
static const char *Infix() { return "//"; }
|
||||
};
|
||||
|
||||
ENUM_CLASS(LogicalOperator, And, Or, Eqv, Neqv)
|
||||
|
||||
template<int KIND>
|
||||
struct LogicalOperation
|
||||
: public Operation<LogicalOperation<KIND>, Type<TypeCategory::Logical, KIND>,
|
||||
|
|
|
@ -204,12 +204,11 @@ static constexpr Precedence GetPrecedence(const Expr<T> &expr) {
|
|||
if constexpr (prec == Precedence::Or) {
|
||||
// Distinguish the four logical binary operations.
|
||||
switch (x.logicalOperator) {
|
||||
SWITCH_COVERS_ALL_CASES
|
||||
case LogicalOperator::And: return Precedence::And;
|
||||
case LogicalOperator::Or: return Precedence::Or;
|
||||
case LogicalOperator::Eqv:
|
||||
case LogicalOperator::Neqv:
|
||||
return Precedence::Equivalence;
|
||||
CRASH_NO_CASE;
|
||||
case LogicalOperator::Neqv: return Precedence::Equivalence;
|
||||
}
|
||||
}
|
||||
return prec;
|
||||
|
@ -282,15 +281,7 @@ std::ostream &Convert<TO, FROMCAT>::AsFortran(std::ostream &o) const {
|
|||
}
|
||||
|
||||
template<typename A> const char *Relational<A>::Infix() const {
|
||||
switch (opr) {
|
||||
case RelationalOperator::LT: return "<";
|
||||
case RelationalOperator::LE: return "<=";
|
||||
case RelationalOperator::EQ: return "==";
|
||||
case RelationalOperator::NE: return "/=";
|
||||
case RelationalOperator::GE: return ">=";
|
||||
case RelationalOperator::GT: return ">";
|
||||
}
|
||||
return nullptr;
|
||||
return common::AsFortran(opr);
|
||||
}
|
||||
|
||||
std::ostream &Relational<SomeType>::AsFortran(std::ostream &o) const {
|
||||
|
@ -299,13 +290,7 @@ std::ostream &Relational<SomeType>::AsFortran(std::ostream &o) const {
|
|||
}
|
||||
|
||||
template<int KIND> const char *LogicalOperation<KIND>::Infix() const {
|
||||
switch (logicalOperator) {
|
||||
case LogicalOperator::And: return ".and.";
|
||||
case LogicalOperator::Or: return ".or.";
|
||||
case LogicalOperator::Eqv: return ".eqv.";
|
||||
case LogicalOperator::Neqv: return ".neqv.";
|
||||
}
|
||||
return nullptr;
|
||||
return AsFortran(logicalOperator);
|
||||
}
|
||||
|
||||
template<typename T>
|
||||
|
|
|
@ -287,21 +287,21 @@ std::optional<Expr<SomeType>> NumericOperation(
|
|||
return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
|
||||
std::move(zx), std::move(zy)));
|
||||
},
|
||||
[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&zy) {
|
||||
[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
|
||||
return MixedComplexLeft<OPR>(
|
||||
messages, std::move(zx), std::move(zy), defaultRealKind);
|
||||
messages, std::move(zx), std::move(iy), defaultRealKind);
|
||||
},
|
||||
[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&zy) {
|
||||
[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
|
||||
return MixedComplexLeft<OPR>(
|
||||
messages, std::move(zx), std::move(zy), defaultRealKind);
|
||||
messages, std::move(zx), std::move(ry), defaultRealKind);
|
||||
},
|
||||
[&](Expr<SomeInteger> &&zx, Expr<SomeComplex> &&zy) {
|
||||
[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
|
||||
return MixedComplexRight<OPR>(
|
||||
messages, std::move(zx), std::move(zy), defaultRealKind);
|
||||
messages, std::move(ix), std::move(zy), defaultRealKind);
|
||||
},
|
||||
[&](Expr<SomeReal> &&zx, Expr<SomeComplex> &&zy) {
|
||||
[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
|
||||
return MixedComplexRight<OPR>(
|
||||
messages, std::move(zx), std::move(zy), defaultRealKind);
|
||||
messages, std::move(rx), std::move(zy), defaultRealKind);
|
||||
},
|
||||
// Operations with one typeless operand
|
||||
[&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
|
||||
|
@ -495,17 +495,7 @@ std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
|
|||
},
|
||||
// Default case
|
||||
[&](auto &&, auto &&) {
|
||||
// TODO: defined operator
|
||||
auto xtype{x.GetType()};
|
||||
auto ytype{y.GetType()};
|
||||
if (xtype.has_value() && ytype.has_value()) {
|
||||
messages.Say(
|
||||
"Relational operands do not have comparable types (%s vs. %s)"_err_en_US,
|
||||
xtype->AsFortran(), ytype->AsFortran());
|
||||
} else {
|
||||
messages.Say(
|
||||
"Relational operands do not have comparable types"_err_en_US);
|
||||
}
|
||||
DIE("invalid types for relational operator");
|
||||
return std::optional<Expr<LogicalResult>>{};
|
||||
},
|
||||
},
|
||||
|
|
|
@ -47,8 +47,13 @@ using MaybeExpr =
|
|||
// and appears here in namespace Fortran::evaluate for convenience.
|
||||
namespace Fortran::evaluate {
|
||||
|
||||
using common::NumericOperator;
|
||||
using common::TypeCategory;
|
||||
|
||||
static inline std::string ToUpperCase(const std::string &str) {
|
||||
return parser::ToUpperCaseLetters(str);
|
||||
}
|
||||
|
||||
struct DynamicTypeWithLength : public DynamicType {
|
||||
explicit DynamicTypeWithLength(const DynamicType &t) : DynamicType{t} {}
|
||||
std::optional<Expr<SubscriptInteger>> LEN() const;
|
||||
|
@ -136,23 +141,46 @@ common::IfNoLvalue<MaybeExpr, WRAPPED> TypedWrapper(
|
|||
class ArgumentAnalyzer {
|
||||
public:
|
||||
explicit ArgumentAnalyzer(ExpressionAnalyzer &context) : context_{context} {}
|
||||
bool success() const { return success_; }
|
||||
bool fatalErrors() const { return fatalErrors_; }
|
||||
ActualArguments &&GetActuals() {
|
||||
CHECK(success_);
|
||||
CHECK(!fatalErrors_);
|
||||
return std::move(actuals_);
|
||||
}
|
||||
template<typename T> void Analyze(const T &x) {
|
||||
actuals_.emplace_back(context_.Analyze(x));
|
||||
success_ &= actuals_.back().has_value();
|
||||
Expr<SomeType> GetAsExpr(std::size_t i) const {
|
||||
return DEREF(actuals_.at(i).value().UnwrapExpr());
|
||||
}
|
||||
void Analyze(const common::Indirection<parser::Expr> &x) {
|
||||
Analyze(x.value());
|
||||
}
|
||||
void Analyze(const parser::Expr &x) {
|
||||
actuals_.emplace_back(AnalyzeExpr(x));
|
||||
fatalErrors_ |= !actuals_.back().has_value();
|
||||
}
|
||||
void Analyze(const parser::ActualArgSpec &, bool isSubroutine);
|
||||
|
||||
bool IsIntrinsicRelational(RelationalOperator) const;
|
||||
bool IsIntrinsicLogical() const;
|
||||
bool IsIntrinsicNumeric() const;
|
||||
bool IsIntrinsicConcat() const;
|
||||
|
||||
// Find and return a user-defined operator for opr or report an error.
|
||||
// The provided message is used if there is no such operator.
|
||||
MaybeExpr TryDefinedOp(const char *, parser::MessageFixedText &&);
|
||||
MaybeExpr TryDefinedOp(RelationalOperator, parser::MessageFixedText &&);
|
||||
|
||||
private:
|
||||
std::optional<ActualArgument> Analyze(const parser::Expr &);
|
||||
std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
|
||||
bool AreConformable() const;
|
||||
const Symbol *FindDefinedOp(const char *) const;
|
||||
std::optional<DynamicType> GetType(std::size_t) const;
|
||||
void SayNoMatch(const char *);
|
||||
std::string TypeAsFortran(std::size_t);
|
||||
bool AnyUntypedOperand();
|
||||
|
||||
ExpressionAnalyzer &context_;
|
||||
ActualArguments actuals_;
|
||||
bool success_{true};
|
||||
parser::CharBlock source_;
|
||||
bool fatalErrors_{false};
|
||||
};
|
||||
|
||||
// Wraps a data reference in a typed Designator<>, and a procedure
|
||||
|
@ -1713,7 +1741,7 @@ MaybeExpr ExpressionAnalyzer::AnalyzeCall(
|
|||
for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
|
||||
analyzer.Analyze(arg, isSubroutine);
|
||||
}
|
||||
if (analyzer.success()) {
|
||||
if (!analyzer.fatalErrors()) {
|
||||
// TODO: map non-intrinsic generic procedure to specific procedure
|
||||
if (std::optional<CalleeAndArguments> callee{
|
||||
GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
|
||||
|
@ -1793,51 +1821,44 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
|
|||
return std::nullopt;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
|
||||
MaybeExpr value{Analyze(x.v.value())};
|
||||
if (value.has_value()) {
|
||||
if (!std::visit(
|
||||
[&](const auto &y) {
|
||||
using yTy = std::decay_t<decltype(y)>;
|
||||
if constexpr (std::is_same_v<yTy, BOZLiteralConstant>) {
|
||||
// allow and ignore +Z'1', it's harmless
|
||||
return true;
|
||||
} else if constexpr (!IsNumericCategoryExpr<yTy>()) {
|
||||
Say("Operand of unary + must have numeric type"_err_en_US);
|
||||
return false;
|
||||
} else {
|
||||
return true;
|
||||
}
|
||||
},
|
||||
value->u)) {
|
||||
return std::nullopt;
|
||||
static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
|
||||
NumericOperator opr, const parser::Expr::IntrinsicUnary &x) {
|
||||
ArgumentAnalyzer analyzer{context};
|
||||
analyzer.Analyze(x.v);
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicNumeric()) {
|
||||
if (opr == NumericOperator::Add) {
|
||||
return analyzer.GetAsExpr(0);
|
||||
} else {
|
||||
return Negation(context.GetContextualMessages(), analyzer.GetAsExpr(0));
|
||||
}
|
||||
} else {
|
||||
return analyzer.TryDefinedOp(AsFortran(opr),
|
||||
"Operand of unary %s must be numeric; have %s"_err_en_US);
|
||||
}
|
||||
return value;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
|
||||
return NumericUnaryHelper(*this, NumericOperator::Add, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
|
||||
if (MaybeExpr operand{Analyze(x.v.value())}) {
|
||||
return Negation(GetContextualMessages(), std::move(*operand));
|
||||
}
|
||||
return std::nullopt;
|
||||
return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
|
||||
if (MaybeExpr operand{Analyze(x.v.value())}) {
|
||||
return std::visit(
|
||||
common::visitors{
|
||||
[](Expr<SomeLogical> &&lx) -> MaybeExpr {
|
||||
return {AsGenericExpr(LogicalNegation(std::move(lx)))};
|
||||
},
|
||||
[&](auto &&) -> MaybeExpr {
|
||||
Say("Operand of .NOT. must be LOGICAL"_err_en_US);
|
||||
return std::nullopt;
|
||||
},
|
||||
},
|
||||
std::move(operand->u));
|
||||
ArgumentAnalyzer analyzer{*this};
|
||||
analyzer.Analyze(x.v);
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicLogical()) {
|
||||
return AsGenericExpr(
|
||||
LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(0).u)));
|
||||
} else {
|
||||
return analyzer.TryDefinedOp(
|
||||
".not.", "Operand of %s must be LOGICAL; have %s"_err_en_US);
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
|
||||
|
@ -1863,7 +1884,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
|
|||
const auto &name{std::get<parser::DefinedOpName>(x.t).v};
|
||||
ArgumentAnalyzer analyzer{*this};
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
if (analyzer.success()) {
|
||||
if (!analyzer.fatalErrors()) {
|
||||
if (auto callee{GetCalleeAndArguments(name, analyzer.GetActuals())}) {
|
||||
return MakeFunctionRef(name.source,
|
||||
std::move(callee->procedureDesignator), std::move(callee->arguments));
|
||||
|
@ -1873,38 +1894,42 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
|
|||
}
|
||||
// Binary (dyadic) operations
|
||||
|
||||
// TODO: check defined operators for illegal intrinsic operator cases
|
||||
template<template<typename> class OPR, typename PARSED>
|
||||
MaybeExpr BinaryOperationHelper(ExpressionAnalyzer &context, const PARSED &x) {
|
||||
if (auto both{common::AllPresent(context.Analyze(std::get<0>(x.t).value()),
|
||||
context.Analyze(std::get<1>(x.t).value()))}) {
|
||||
ConformabilityCheck(context.GetContextualMessages(), std::get<0>(*both),
|
||||
std::get<1>(*both));
|
||||
template<template<typename> class OPR>
|
||||
MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
|
||||
const parser::Expr::IntrinsicBinary &x) {
|
||||
ArgumentAnalyzer analyzer{context};
|
||||
analyzer.Analyze(std::get<0>(x.t));
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicNumeric()) {
|
||||
return NumericOperation<OPR>(context.GetContextualMessages(),
|
||||
std::get<0>(std::move(*both)), std::get<1>(std::move(*both)),
|
||||
analyzer.GetAsExpr(0), analyzer.GetAsExpr(1),
|
||||
context.GetDefaultKind(TypeCategory::Real));
|
||||
} else {
|
||||
return analyzer.TryDefinedOp(AsFortran(opr),
|
||||
"Operands of %s must be numeric; have %s and %s"_err_en_US);
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
|
||||
return BinaryOperationHelper<Power>(*this, x);
|
||||
return NumericBinaryHelper<Power>(*this, NumericOperator::Power, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
|
||||
return BinaryOperationHelper<Multiply>(*this, x);
|
||||
return NumericBinaryHelper<Multiply>(*this, NumericOperator::Multiply, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
|
||||
return BinaryOperationHelper<Divide>(*this, x);
|
||||
return NumericBinaryHelper<Divide>(*this, NumericOperator::Divide, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
|
||||
return BinaryOperationHelper<Add>(*this, x);
|
||||
return NumericBinaryHelper<Add>(*this, NumericOperator::Add, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
|
||||
return BinaryOperationHelper<Subtract>(*this, x);
|
||||
return NumericBinaryHelper<Subtract>(*this, NumericOperator::Subtract, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(
|
||||
|
@ -1919,49 +1944,57 @@ MaybeExpr ExpressionAnalyzer::Analyze(
|
|||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
|
||||
if (auto both{common::AllPresent(Analyze(std::get<0>(x.t).value()),
|
||||
Analyze(std::get<1>(x.t).value()))}) {
|
||||
ConformabilityCheck(
|
||||
GetContextualMessages(), std::get<0>(*both), std::get<1>(*both));
|
||||
ArgumentAnalyzer analyzer{*this};
|
||||
analyzer.Analyze(std::get<0>(x.t));
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicConcat()) {
|
||||
return std::visit(
|
||||
common::visitors{
|
||||
[&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
|
||||
return std::visit(
|
||||
[&](auto &&cxk, auto &&cyk) -> MaybeExpr {
|
||||
using Ty = ResultType<decltype(cxk)>;
|
||||
if constexpr (std::is_same_v<Ty,
|
||||
ResultType<decltype(cyk)>>) {
|
||||
return {AsGenericExpr(
|
||||
Concat<Ty::kind>{std::move(cxk), std::move(cyk)})};
|
||||
} else {
|
||||
Say("Operands of // must be the same kind of CHARACTER"_err_en_US);
|
||||
return std::nullopt;
|
||||
}
|
||||
},
|
||||
std::move(cx.u), std::move(cy.u));
|
||||
},
|
||||
[&](auto &&, auto &&) -> MaybeExpr {
|
||||
Say("Operands of // must be CHARACTER"_err_en_US);
|
||||
return std::nullopt;
|
||||
},
|
||||
[&](auto &&x, auto &&y) -> MaybeExpr {
|
||||
using T = ResultType<decltype(x)>;
|
||||
if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
|
||||
return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
|
||||
} else {
|
||||
DIE("different types for intrinsic concat");
|
||||
}
|
||||
},
|
||||
std::move(std::get<0>(*both).u), std::move(std::get<1>(*both).u));
|
||||
std::move(std::get<Expr<SomeCharacter>>(analyzer.GetAsExpr(0).u).u),
|
||||
std::move(std::get<Expr<SomeCharacter>>(analyzer.GetAsExpr(1).u).u));
|
||||
} else {
|
||||
return analyzer.TryDefinedOp("//",
|
||||
"Operands of %s must be CHARACTER with the same kind; have %s and %s"_err_en_US);
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
|
||||
// TODO: check defined operators for illegal intrinsic operator cases
|
||||
template<typename PARSED>
|
||||
MaybeExpr RelationHelper(
|
||||
ExpressionAnalyzer &context, RelationalOperator opr, const PARSED &x) {
|
||||
if (auto both{common::AllPresent(context.Analyze(std::get<0>(x.t).value()),
|
||||
context.Analyze(std::get<1>(x.t).value()))}) {
|
||||
ConformabilityCheck(context.GetContextualMessages(), std::get<0>(*both),
|
||||
std::get<1>(*both));
|
||||
return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
|
||||
std::get<0>(std::move(*both)), std::get<1>(std::move(*both))));
|
||||
// The Name represents a user-defined intrinsic operator.
|
||||
// If the actuals match one of the specific procedures, return a function ref.
|
||||
// Otherwise report the error in messages.
|
||||
MaybeExpr ExpressionAnalyzer::AnalyzeDefinedOp(parser::Messages &messages,
|
||||
const parser::Name &name, ActualArguments &&actuals) {
|
||||
auto restorer{GetContextualMessages().SetMessages(messages)};
|
||||
if (auto callee{GetCalleeAndArguments(name, std::move(actuals))}) {
|
||||
return MakeFunctionRef(name.source, std::move(callee->procedureDesignator),
|
||||
std::move(callee->arguments));
|
||||
} else {
|
||||
return std::nullopt;
|
||||
}
|
||||
}
|
||||
|
||||
MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
|
||||
const parser::Expr::IntrinsicBinary &x) {
|
||||
ArgumentAnalyzer analyzer{context};
|
||||
analyzer.Analyze(std::get<0>(x.t));
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicRelational(opr)) {
|
||||
return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
|
||||
analyzer.GetAsExpr(0), analyzer.GetAsExpr(1)));
|
||||
} else {
|
||||
return analyzer.TryDefinedOp(opr,
|
||||
"Operands of %s must have comparable types; have %s and %s"_err_en_US);
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::LT &x) {
|
||||
|
@ -1988,51 +2021,41 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::GT &x) {
|
|||
return RelationHelper(*this, RelationalOperator::GT, x);
|
||||
}
|
||||
|
||||
// TODO: check defined operators for illegal intrinsic operator cases
|
||||
template<typename PARSED>
|
||||
MaybeExpr LogicalHelper(
|
||||
ExpressionAnalyzer &context, LogicalOperator opr, const PARSED &x) {
|
||||
if (auto both{common::AllPresent(context.Analyze(std::get<0>(x.t).value()),
|
||||
context.Analyze(std::get<1>(x.t).value()))}) {
|
||||
return std::visit(
|
||||
common::visitors{
|
||||
[&](Expr<SomeLogical> &&lx, Expr<SomeLogical> &&ly) -> MaybeExpr {
|
||||
ConformabilityCheck(context.GetContextualMessages(), lx, ly);
|
||||
return {AsGenericExpr(
|
||||
BinaryLogicalOperation(opr, std::move(lx), std::move(ly)))};
|
||||
},
|
||||
[&](auto &&, auto &&) -> MaybeExpr {
|
||||
// TODO: extension: INTEGER and typeless operands
|
||||
// ifort and PGI accept them if not overridden
|
||||
// need to define IAND, IOR, IEOR intrinsic representation
|
||||
context.Say(
|
||||
"operands to LOGICAL operation must be LOGICAL"_err_en_US);
|
||||
return {};
|
||||
},
|
||||
},
|
||||
std::move(std::get<0>(*both).u), std::move(std::get<1>(*both).u));
|
||||
MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
|
||||
const parser::Expr::IntrinsicBinary &x) {
|
||||
ArgumentAnalyzer analyzer{context};
|
||||
analyzer.Analyze(std::get<0>(x.t));
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
if (analyzer.fatalErrors()) {
|
||||
return std::nullopt;
|
||||
} else if (analyzer.IsIntrinsicLogical()) {
|
||||
return AsGenericExpr(BinaryLogicalOperation(opr,
|
||||
std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(0).u),
|
||||
std::get<Expr<SomeLogical>>(analyzer.GetAsExpr(1).u)));
|
||||
} else {
|
||||
return analyzer.TryDefinedOp(AsFortran(opr),
|
||||
"Operands of %s must be LOGICAL; have %s and %s"_err_en_US);
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::AND &x) {
|
||||
return LogicalHelper(*this, LogicalOperator::And, x);
|
||||
return LogicalBinaryHelper(*this, LogicalOperator::And, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::OR &x) {
|
||||
return LogicalHelper(*this, LogicalOperator::Or, x);
|
||||
return LogicalBinaryHelper(*this, LogicalOperator::Or, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::EQV &x) {
|
||||
return LogicalHelper(*this, LogicalOperator::Eqv, x);
|
||||
return LogicalBinaryHelper(*this, LogicalOperator::Eqv, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
|
||||
return LogicalHelper(*this, LogicalOperator::Neqv, x);
|
||||
return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::XOR &x) {
|
||||
return LogicalHelper(*this, LogicalOperator::Neqv, x);
|
||||
return LogicalBinaryHelper(*this, LogicalOperator::Neqv, x);
|
||||
}
|
||||
|
||||
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
|
||||
|
@ -2040,7 +2063,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
|
|||
ArgumentAnalyzer analyzer{*this};
|
||||
analyzer.Analyze(std::get<1>(x.t));
|
||||
analyzer.Analyze(std::get<2>(x.t));
|
||||
if (analyzer.success()) {
|
||||
if (!analyzer.fatalErrors()) {
|
||||
if (auto callee{GetCalleeAndArguments(name, analyzer.GetActuals())}) {
|
||||
return MakeFunctionRef(name.source,
|
||||
std::move(callee->procedureDesignator), std::move(callee->arguments));
|
||||
|
@ -2231,7 +2254,7 @@ bool ExpressionAnalyzer::CheckIntrinsicKind(
|
|||
return true;
|
||||
} else {
|
||||
Say("%s(KIND=%jd) is not a supported type"_err_en_US,
|
||||
parser::ToUpperCaseLetters(EnumToString(category)), kind);
|
||||
ToUpperCase(EnumToString(category)), kind);
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
@ -2247,7 +2270,7 @@ bool ExpressionAnalyzer::CheckIntrinsicSize(
|
|||
return true;
|
||||
}
|
||||
Say("%s*%jd is not a supported type"_err_en_US,
|
||||
parser::ToUpperCaseLetters(EnumToString(category)), size);
|
||||
ToUpperCase(EnumToString(category)), size);
|
||||
return false;
|
||||
}
|
||||
|
||||
|
@ -2278,21 +2301,21 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
|
|||
if (auto type{result->GetType()}) {
|
||||
if (type->category() != category) {
|
||||
Say(at, "Must have %s type, but is %s"_err_en_US,
|
||||
parser::ToUpperCaseLetters(EnumToString(category)),
|
||||
parser::ToUpperCaseLetters(type->AsFortran()));
|
||||
ToUpperCase(EnumToString(category)),
|
||||
ToUpperCase(type->AsFortran()));
|
||||
return false;
|
||||
} else if (defaultKind) {
|
||||
int kind{context_.GetDefaultKind(category)};
|
||||
if (type->kind() != kind) {
|
||||
Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
|
||||
kind, parser::ToUpperCaseLetters(EnumToString(category)),
|
||||
parser::ToUpperCaseLetters(type->AsFortran()));
|
||||
kind, ToUpperCase(EnumToString(category)),
|
||||
ToUpperCase(type->AsFortran()));
|
||||
return false;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
Say(at, "Must have %s type, but is typeless"_err_en_US,
|
||||
parser::ToUpperCaseLetters(EnumToString(category)));
|
||||
ToUpperCase(EnumToString(category)));
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
@ -2372,7 +2395,7 @@ void ArgumentAnalyzer::Analyze(
|
|||
[&](const common::Indirection<parser::Expr> &x) {
|
||||
// TODO: Distinguish & handle procedure name and
|
||||
// proc-component-ref
|
||||
actual = Analyze(x.value());
|
||||
actual = AnalyzeExpr(x.value());
|
||||
},
|
||||
[&](const parser::AltReturnSpec &) {
|
||||
if (!isSubroutine) {
|
||||
|
@ -2394,12 +2417,82 @@ void ArgumentAnalyzer::Analyze(
|
|||
}
|
||||
actuals_.emplace_back(std::move(*actual));
|
||||
} else {
|
||||
success_ = false;
|
||||
fatalErrors_ = true;
|
||||
}
|
||||
}
|
||||
|
||||
std::optional<ActualArgument> ArgumentAnalyzer::Analyze(
|
||||
bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr) const {
|
||||
auto cat0{GetType(0)->category()};
|
||||
auto cat1{GetType(1)->category()};
|
||||
if (!AreConformable()) {
|
||||
return false;
|
||||
} else if (IsNumericTypeCategory(cat0) && IsNumericTypeCategory(cat1)) {
|
||||
// numeric types: EQ/NE always ok, others ok for non-complex
|
||||
return opr == RelationalOperator::EQ || opr == RelationalOperator::NE ||
|
||||
(cat0 != TypeCategory::Complex && cat1 != TypeCategory::Complex);
|
||||
} else {
|
||||
// not both numeric: only Character is ok
|
||||
return cat0 == TypeCategory::Character && cat1 == TypeCategory::Character;
|
||||
}
|
||||
}
|
||||
|
||||
bool ArgumentAnalyzer::IsIntrinsicNumeric() const {
|
||||
return IsNumericTypeCategory(GetType(0)->category()) &&
|
||||
(actuals_.size() == 1 ||
|
||||
(AreConformable() && IsNumericTypeCategory(GetType(1)->category())));
|
||||
}
|
||||
|
||||
bool ArgumentAnalyzer::IsIntrinsicLogical() const {
|
||||
return GetType(0)->category() == TypeCategory::Logical &&
|
||||
(actuals_.size() == 1 ||
|
||||
(AreConformable() &&
|
||||
GetType(1)->category() == TypeCategory::Logical));
|
||||
}
|
||||
|
||||
bool ArgumentAnalyzer::IsIntrinsicConcat() const {
|
||||
return AreConformable() &&
|
||||
GetType(0)->category() == TypeCategory::Character &&
|
||||
GetType(1)->category() == TypeCategory::Character &&
|
||||
GetType(0)->kind() == GetType(1)->kind();
|
||||
}
|
||||
|
||||
MaybeExpr ArgumentAnalyzer::TryDefinedOp(
|
||||
const char *opr, parser::MessageFixedText &&error) {
|
||||
const Symbol *symbol{AnyUntypedOperand() ? nullptr : FindDefinedOp(opr)};
|
||||
if (!symbol) {
|
||||
if (actuals_.size() == 1 || AreConformable()) {
|
||||
context_.Say(std::move(error), ToUpperCase(opr), TypeAsFortran(0),
|
||||
TypeAsFortran(1));
|
||||
} else {
|
||||
context_.Say(
|
||||
"Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
|
||||
ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
|
||||
}
|
||||
return std::nullopt;
|
||||
}
|
||||
parser::Messages messages;
|
||||
parser::Name name{source_, const_cast<Symbol *>(symbol)};
|
||||
if (auto result{context_.AnalyzeDefinedOp(messages, name, GetActuals())}) {
|
||||
return result;
|
||||
} else {
|
||||
SayNoMatch(opr);
|
||||
return std::nullopt;
|
||||
}
|
||||
}
|
||||
|
||||
MaybeExpr ArgumentAnalyzer::TryDefinedOp(
|
||||
RelationalOperator opr, parser::MessageFixedText &&error) {
|
||||
for (const char *name : AllFortranNames(opr)) {
|
||||
if (FindDefinedOp(name)) {
|
||||
return TryDefinedOp(name, std::move(error));
|
||||
}
|
||||
}
|
||||
return TryDefinedOp(AsFortran(opr), std::move(error));
|
||||
}
|
||||
|
||||
std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
|
||||
const parser::Expr &expr) {
|
||||
source_.ExtendToCover(expr.source);
|
||||
if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
|
||||
return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
|
||||
} else if (MaybeExpr argExpr{context_.Analyze(expr)}) {
|
||||
|
@ -2431,6 +2524,68 @@ std::optional<ActualArgument> ArgumentAnalyzer::Analyze(
|
|||
}
|
||||
}
|
||||
|
||||
bool ArgumentAnalyzer::AreConformable() const {
|
||||
CHECK(!fatalErrors_ && actuals_.size() == 2);
|
||||
return evaluate::AreConformable(*actuals_[0], *actuals_[1]);
|
||||
}
|
||||
|
||||
const Symbol *ArgumentAnalyzer::FindDefinedOp(const char *opr) const {
|
||||
const auto &scope{context_.context().FindScope(source_)};
|
||||
return scope.FindSymbol(parser::CharBlock{"operator("s + opr + ')'});
|
||||
}
|
||||
|
||||
std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {
|
||||
return i < actuals_.size() ? actuals_[i].value().GetType() : std::nullopt;
|
||||
}
|
||||
|
||||
// Report error resolving opr when there is a user-defined one available
|
||||
void ArgumentAnalyzer::SayNoMatch(const char *opr) {
|
||||
auto rank0{actuals_[0]->Rank()};
|
||||
if (actuals_.size() == 1) {
|
||||
if (rank0 > 0) {
|
||||
context_.Say("No user-defined or intrinsic %s operator matches "
|
||||
"rank %d array of %s"_err_en_US,
|
||||
ToUpperCase(opr), rank0, TypeAsFortran(0));
|
||||
} else {
|
||||
context_.Say("No user-defined or intrinsic %s operator matches "
|
||||
"operand type %s"_err_en_US,
|
||||
ToUpperCase(opr), TypeAsFortran(0));
|
||||
}
|
||||
} else {
|
||||
auto rank1{actuals_[1]->Rank()};
|
||||
if (rank0 > 0 && rank1 > 0 && rank0 != rank1) {
|
||||
context_.Say("No user-defined or intrinsic %s operator matches "
|
||||
"rank %d array of %s and rank %d array of %s"_err_en_US,
|
||||
ToUpperCase(opr), rank0, TypeAsFortran(0), rank1, TypeAsFortran(1));
|
||||
} else {
|
||||
context_.Say("No user-defined or intrinsic %s operator matches "
|
||||
"operand types %s and %s"_err_en_US,
|
||||
ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
|
||||
if (std::optional<DynamicType> type{GetType(i)}) {
|
||||
return type->category() == TypeCategory::Derived
|
||||
? "TYPE("s + type->AsFortran() + ')'
|
||||
: type->category() == TypeCategory::Character
|
||||
? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
|
||||
: ToUpperCase(type->AsFortran());
|
||||
} else {
|
||||
return "untyped";
|
||||
}
|
||||
}
|
||||
|
||||
bool ArgumentAnalyzer::AnyUntypedOperand() {
|
||||
for (const auto &actual : actuals_) {
|
||||
if (!actual.value().GetType().has_value()) {
|
||||
return true;
|
||||
}
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
} // namespace Fortran::evaluate
|
||||
|
||||
namespace Fortran::semantics {
|
||||
|
|
|
@ -311,6 +311,8 @@ private:
|
|||
MaybeExpr TopLevelChecks(DataRef &&);
|
||||
std::optional<Expr<SubscriptInteger>> GetSubstringBound(
|
||||
const std::optional<parser::ScalarIntExpr> &);
|
||||
MaybeExpr AnalyzeDefinedOp(
|
||||
parser::Messages &, const parser::Name &, ActualArguments &&);
|
||||
|
||||
struct CalleeAndArguments {
|
||||
ProcedureDesignator procedureDesignator;
|
||||
|
@ -344,6 +346,7 @@ private:
|
|||
FoldingContext &foldingContext_{context_.foldingContext()};
|
||||
std::map<parser::CharBlock, int> acImpliedDos_; // values are INTEGER kinds
|
||||
bool fatalErrors_{false};
|
||||
friend class ArgumentAnalyzer;
|
||||
};
|
||||
|
||||
template<typename L, typename R>
|
||||
|
|
|
@ -99,6 +99,7 @@ set(ERROR_TESTS
|
|||
resolve60.f90
|
||||
resolve61.f90
|
||||
resolve62.f90
|
||||
resolve63.f90
|
||||
stop01.f90
|
||||
structconst01.f90
|
||||
structconst02.f90
|
||||
|
@ -246,6 +247,7 @@ set(MODFILE_TESTS
|
|||
modfile30.f90
|
||||
modfile31.f90
|
||||
modfile32.f90
|
||||
modfile33.f90
|
||||
)
|
||||
|
||||
set(LABEL_TESTS
|
||||
|
|
|
@ -0,0 +1,597 @@
|
|||
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
|
||||
!
|
||||
! Licensed under the Apache License, Version 2.0 (the "License");
|
||||
! you may not use this file except in compliance with the License.
|
||||
! You may obtain a copy of the License at
|
||||
!
|
||||
! http://www.apache.org/licenses/LICENSE-2.0
|
||||
!
|
||||
! Unless required by applicable law or agreed to in writing, software
|
||||
! distributed under the License is distributed on an "AS IS" BASIS,
|
||||
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
! See the License for the specific language governing permissions and
|
||||
! limitations under the License.
|
||||
|
||||
! Resolution of user-defined operators in expressions.
|
||||
! Test by using generic function in a specification expression that needs
|
||||
! to be written to a .mod file.
|
||||
|
||||
! Numeric operators
|
||||
module m1
|
||||
type :: t
|
||||
sequence
|
||||
end type
|
||||
interface operator(+)
|
||||
pure integer(8) function add_ll(x, y)
|
||||
logical, intent(in) :: x, y
|
||||
end
|
||||
pure integer(8) function add_li(x, y)
|
||||
logical, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
end
|
||||
pure integer(8) function add_tt(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
interface operator(/)
|
||||
pure integer(8) function div_tz(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
complex, intent(in) :: y
|
||||
end
|
||||
pure integer(8) function div_ct(x, y)
|
||||
import :: t
|
||||
character(10), intent(in) :: x
|
||||
type(t), intent(in) :: y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y, z)
|
||||
logical :: x, y
|
||||
real :: z(x + y) ! resolves to add_ll
|
||||
end
|
||||
subroutine s2(x, y, z)
|
||||
logical :: x
|
||||
integer :: y
|
||||
real :: z(x + y) ! resolves to add_li
|
||||
end
|
||||
subroutine s3(x, y, z)
|
||||
type(t) :: x
|
||||
complex :: y
|
||||
real :: z(x / y) ! resolves to div_tz
|
||||
end
|
||||
subroutine s4(x, y, z)
|
||||
character(10) :: x
|
||||
type(t) :: y
|
||||
real :: z(x / y) ! resolves to div_ct
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m1.mod
|
||||
!module m1
|
||||
! type :: t
|
||||
! sequence
|
||||
! end type
|
||||
! interface operator(+)
|
||||
! procedure :: add_ll
|
||||
! procedure :: add_li
|
||||
! procedure :: add_tt
|
||||
! end interface
|
||||
! interface
|
||||
! pure function add_ll(x, y)
|
||||
! logical(4), intent(in) :: x
|
||||
! logical(4), intent(in) :: y
|
||||
! integer(8) :: add_ll
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function add_li(x, y)
|
||||
! logical(4), intent(in) :: x
|
||||
! integer(4), intent(in) :: y
|
||||
! integer(8) :: add_li
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function add_tt(x, y)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! type(t), intent(in) :: y
|
||||
! integer(8) :: add_tt
|
||||
! end
|
||||
! end interface
|
||||
! interface operator(/)
|
||||
! procedure :: div_tz
|
||||
! procedure :: div_ct
|
||||
! end interface
|
||||
! interface
|
||||
! pure function div_tz(x, y)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! complex(4), intent(in) :: y
|
||||
! integer(8) :: div_tz
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function div_ct(x, y)
|
||||
! import :: t
|
||||
! character(10_4, 1), intent(in) :: x
|
||||
! type(t), intent(in) :: y
|
||||
! integer(8) :: div_ct
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y, z)
|
||||
! logical(4) :: x
|
||||
! logical(4) :: y
|
||||
! real(4) :: z(1_8:add_ll(x, y))
|
||||
! end
|
||||
! subroutine s2(x, y, z)
|
||||
! logical(4) :: x
|
||||
! integer(4) :: y
|
||||
! real(4) :: z(1_8:add_li(x, y))
|
||||
! end
|
||||
! subroutine s3(x, y, z)
|
||||
! type(t) :: x
|
||||
! complex(4) :: y
|
||||
! real(4) :: z(1_8:div_tz(x, y))
|
||||
! end
|
||||
! subroutine s4(x, y, z)
|
||||
! character(10_4, 1) :: x
|
||||
! type(t) :: y
|
||||
! real(4) :: z(1_8:div_ct(x, y))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Logical operators
|
||||
module m2
|
||||
type :: t
|
||||
sequence
|
||||
end type
|
||||
interface operator(.And.)
|
||||
pure integer(8) function and_ti(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
end
|
||||
pure integer(8) function and_li(x, y)
|
||||
logical, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
end
|
||||
pure integer(8) function and_tt(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y, z)
|
||||
type(t) :: x
|
||||
integer :: y
|
||||
real :: z(x .and. y) ! resolves to and_ti
|
||||
end
|
||||
subroutine s2(x, y, z)
|
||||
logical :: x
|
||||
integer :: y
|
||||
real :: z(x .and. y) ! resolves to and_li
|
||||
end
|
||||
subroutine s3(x, y, z)
|
||||
type(t) :: x, y
|
||||
real :: z(x .and. y) ! resolves to and_tt
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m2.mod
|
||||
!module m2
|
||||
! type :: t
|
||||
! sequence
|
||||
! end type
|
||||
! interface operator( .and.)
|
||||
! procedure :: and_ti
|
||||
! procedure :: and_li
|
||||
! procedure :: and_tt
|
||||
! end interface
|
||||
! interface
|
||||
! pure function and_ti(x, y)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! integer(4), intent(in) :: y
|
||||
! integer(8) :: and_ti
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function and_li(x, y)
|
||||
! logical(4), intent(in) :: x
|
||||
! integer(4), intent(in) :: y
|
||||
! integer(8) :: and_li
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function and_tt(x, y)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! type(t), intent(in) :: y
|
||||
! integer(8) :: and_tt
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y, z)
|
||||
! type(t) :: x
|
||||
! integer(4) :: y
|
||||
! real(4) :: z(1_8:and_ti(x, y))
|
||||
! end
|
||||
! subroutine s2(x, y, z)
|
||||
! logical(4) :: x
|
||||
! integer(4) :: y
|
||||
! real(4) :: z(1_8:and_li(x, y))
|
||||
! end
|
||||
! subroutine s3(x, y, z)
|
||||
! type(t) :: x
|
||||
! type(t) :: y
|
||||
! real(4) :: z(1_8:and_tt(x, y))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Relational operators
|
||||
module m3
|
||||
type :: t
|
||||
sequence
|
||||
end type
|
||||
interface operator(<>)
|
||||
pure integer(8) function ne_it(x, y)
|
||||
import :: t
|
||||
integer, intent(in) :: x
|
||||
type(t), intent(in) :: y
|
||||
end
|
||||
end interface
|
||||
interface operator(/=)
|
||||
pure integer(8) function ne_tt(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
interface operator(.ne.)
|
||||
pure integer(8) function ne_ci(x, y)
|
||||
character(len=*), intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y, z)
|
||||
integer :: x
|
||||
type(t) :: y
|
||||
real :: z(x /= y) ! resolves to ne_it
|
||||
end
|
||||
subroutine s2(x, y, z)
|
||||
type(t) :: x
|
||||
type(t) :: y
|
||||
real :: z(x .ne. y) ! resolves to ne_tt
|
||||
end
|
||||
subroutine s3(x, y, z)
|
||||
character(len=*) :: x
|
||||
integer :: y
|
||||
real :: z(x <> y) ! resolves to ne_ci
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m3.mod
|
||||
!module m3
|
||||
! type :: t
|
||||
! sequence
|
||||
! end type
|
||||
! interface operator(<>)
|
||||
! procedure :: ne_it
|
||||
! procedure :: ne_tt
|
||||
! procedure :: ne_ci
|
||||
! end interface
|
||||
! interface
|
||||
! pure function ne_it(x, y)
|
||||
! import :: t
|
||||
! integer(4), intent(in) :: x
|
||||
! type(t), intent(in) :: y
|
||||
! integer(8) :: ne_it
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function ne_tt(x, y)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! type(t), intent(in) :: y
|
||||
! integer(8) :: ne_tt
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function ne_ci(x, y)
|
||||
! character(*, 1), intent(in) :: x
|
||||
! integer(4), intent(in) :: y
|
||||
! integer(8) :: ne_ci
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y, z)
|
||||
! integer(4) :: x
|
||||
! type(t) :: y
|
||||
! real(4) :: z(1_8:ne_it(x, y))
|
||||
! end
|
||||
! subroutine s2(x, y, z)
|
||||
! type(t) :: x
|
||||
! type(t) :: y
|
||||
! real(4) :: z(1_8:ne_tt(x, y))
|
||||
! end
|
||||
! subroutine s3(x, y, z)
|
||||
! character(*, 1) :: x
|
||||
! integer(4) :: y
|
||||
! real(4) :: z(1_8:ne_ci(x, y))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Concatenation
|
||||
module m4
|
||||
type :: t
|
||||
sequence
|
||||
end type
|
||||
interface operator(//)
|
||||
pure integer(8) function concat_12(x, y)
|
||||
character(len=*,kind=1), intent(in) :: x
|
||||
character(len=*,kind=2), intent(in) :: y
|
||||
end
|
||||
pure integer(8) function concat_int_real(x, y)
|
||||
integer, intent(in) :: x
|
||||
real, intent(in) :: y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y, z)
|
||||
character(len=*,kind=1) :: x
|
||||
character(len=*,kind=2) :: y
|
||||
real :: z(x // y) ! resolves to concat_12
|
||||
end
|
||||
subroutine s2(x, y, z)
|
||||
integer :: x
|
||||
real :: y
|
||||
real :: z(x // y) ! resolves to concat_int_real
|
||||
end
|
||||
end
|
||||
!Expect: m4.mod
|
||||
!module m4
|
||||
! type :: t
|
||||
! sequence
|
||||
! end type
|
||||
! interface operator(//)
|
||||
! procedure :: concat_12
|
||||
! procedure :: concat_int_real
|
||||
! end interface
|
||||
! interface
|
||||
! pure function concat_12(x, y)
|
||||
! character(*, 1), intent(in) :: x
|
||||
! character(*, 2), intent(in) :: y
|
||||
! integer(8) :: concat_12
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function concat_int_real(x, y)
|
||||
! integer(4), intent(in) :: x
|
||||
! real(4), intent(in) :: y
|
||||
! integer(8) :: concat_int_real
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y, z)
|
||||
! character(*, 1) :: x
|
||||
! character(*, 2) :: y
|
||||
! real(4) :: z(1_8:concat_12(x, y))
|
||||
! end
|
||||
! subroutine s2(x, y, z)
|
||||
! integer(4) :: x
|
||||
! real(4) :: y
|
||||
! real(4) :: z(1_8:concat_int_real(x, y))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Unary operators
|
||||
module m5
|
||||
type :: t
|
||||
end type
|
||||
interface operator(+)
|
||||
pure integer(8) function plus_l(x)
|
||||
logical, intent(in) :: x
|
||||
end
|
||||
end interface
|
||||
interface operator(-)
|
||||
pure integer(8) function minus_t(x)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
end
|
||||
end interface
|
||||
interface operator(.not.)
|
||||
pure integer(8) function not_t(x)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
end
|
||||
pure integer(8) function not_real(x)
|
||||
real, intent(in) :: x
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y)
|
||||
logical :: x
|
||||
real :: y(+x) ! resolves_to plus_l
|
||||
end
|
||||
subroutine s2(x, y)
|
||||
type(t) :: x
|
||||
real :: y(-x) ! resolves_to minus_t
|
||||
end
|
||||
subroutine s3(x, y)
|
||||
type(t) :: x
|
||||
real :: y(.not. x) ! resolves to not_t
|
||||
end
|
||||
subroutine s4(x, y)
|
||||
real :: y(.not. x) ! resolves to not_real
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m5.mod
|
||||
!module m5
|
||||
! type :: t
|
||||
! end type
|
||||
! interface operator(+)
|
||||
! procedure :: plus_l
|
||||
! end interface
|
||||
! interface
|
||||
! pure function plus_l(x)
|
||||
! logical(4), intent(in) :: x
|
||||
! integer(8) :: plus_l
|
||||
! end
|
||||
! end interface
|
||||
! interface operator(-)
|
||||
! procedure :: minus_t
|
||||
! end interface
|
||||
! interface
|
||||
! pure function minus_t(x)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! integer(8) :: minus_t
|
||||
! end
|
||||
! end interface
|
||||
! interface operator( .not.)
|
||||
! procedure :: not_t
|
||||
! procedure :: not_real
|
||||
! end interface
|
||||
! interface
|
||||
! pure function not_t(x)
|
||||
! import :: t
|
||||
! type(t), intent(in) :: x
|
||||
! integer(8) :: not_t
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function not_real(x)
|
||||
! real(4), intent(in) :: x
|
||||
! integer(8) :: not_real
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y)
|
||||
! logical(4) :: x
|
||||
! real(4) :: y(1_8:plus_l(x))
|
||||
! end
|
||||
! subroutine s2(x, y)
|
||||
! type(t) :: x
|
||||
! real(4) :: y(1_8:minus_t(x))
|
||||
! end
|
||||
! subroutine s3(x, y)
|
||||
! type(t) :: x
|
||||
! real(4) :: y(1_8:not_t(x))
|
||||
! end
|
||||
! subroutine s4(x, y)
|
||||
! real(4) :: x
|
||||
! real(4) :: y(1_8:not_real(x))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Resolved based on shape
|
||||
module m6
|
||||
interface operator(+)
|
||||
pure integer(8) function add(x, y)
|
||||
real, intent(in) :: x(:, :)
|
||||
real, intent(in) :: y(:, :, :)
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(n, x, y, z, a, b)
|
||||
integer(8) :: n
|
||||
real :: x
|
||||
real :: y(4, n)
|
||||
real :: z(2, 2, 2)
|
||||
real :: a(size(x+y)) ! intrinsic +
|
||||
real :: b(y+z) ! resolves to add
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m6.mod
|
||||
!module m6
|
||||
! interface operator(+)
|
||||
! procedure :: add
|
||||
! end interface
|
||||
! interface
|
||||
! pure function add(x, y)
|
||||
! real(4), intent(in) :: x(:, :)
|
||||
! real(4), intent(in) :: y(:, :, :)
|
||||
! integer(8) :: add
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(n, x, y, z, a, b)
|
||||
! integer(8) :: n
|
||||
! real(4) :: x
|
||||
! real(4) :: y(1_8:4_8, 1_8:n)
|
||||
! real(4) :: z(1_8:2_8, 1_8:2_8, 1_8:2_8)
|
||||
! real(4) :: a(1_8:4_8*(n-1_8+1_8))
|
||||
! real(4) :: b(1_8:add(y, z))
|
||||
! end
|
||||
!end
|
||||
|
||||
! Parameterized derived type
|
||||
module m7
|
||||
type :: t(k)
|
||||
integer, kind :: k
|
||||
real(k) :: a
|
||||
end type
|
||||
interface operator(+)
|
||||
pure integer(8) function f1(x, y)
|
||||
import :: t
|
||||
type(t(4)), intent(in) :: x, y
|
||||
end
|
||||
pure integer(8) function f2(x, y)
|
||||
import :: t
|
||||
type(t(8)), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y, z)
|
||||
type(t(4)) :: x, y
|
||||
real :: z(x + y) ! resolves to f1
|
||||
end
|
||||
subroutine s2(x, y, z)
|
||||
type(t(8)) :: x, y
|
||||
real :: z(x + y) ! resolves to f2
|
||||
end
|
||||
end
|
||||
|
||||
!Expect: m7.mod
|
||||
!module m7
|
||||
! type :: t(k)
|
||||
! integer(4), kind :: k
|
||||
! real(int(k, kind=8)) :: a
|
||||
! end type
|
||||
! interface operator(+)
|
||||
! procedure :: f1
|
||||
! procedure :: f2
|
||||
! end interface
|
||||
! interface
|
||||
! pure function f1(x, y)
|
||||
! import :: t
|
||||
! type(t(k=4_4)), intent(in) :: x
|
||||
! type(t(k=4_4)), intent(in) :: y
|
||||
! integer(8) :: f1
|
||||
! end
|
||||
! end interface
|
||||
! interface
|
||||
! pure function f2(x, y)
|
||||
! import :: t
|
||||
! type(t(k=8_4)), intent(in) :: x
|
||||
! type(t(k=8_4)), intent(in) :: y
|
||||
! integer(8) :: f2
|
||||
! end
|
||||
! end interface
|
||||
!contains
|
||||
! subroutine s1(x, y, z)
|
||||
! type(t(k=4_4)) :: x
|
||||
! type(t(k=4_4)) :: y
|
||||
! real(4) :: z(1_8:f1(x, y))
|
||||
! end
|
||||
! subroutine s2(x, y, z)
|
||||
! type(t(k=8_4)) :: x
|
||||
! type(t(k=8_4)) :: y
|
||||
! real(4) :: z(1_8:f2(x, y))
|
||||
! end
|
||||
!end
|
|
@ -0,0 +1,160 @@
|
|||
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
|
||||
!
|
||||
! Licensed under the Apache License, Version 2.0 (the "License");
|
||||
! you may not use this file except in compliance with the License.
|
||||
! You may obtain a copy of the License at
|
||||
!
|
||||
! http://www.apache.org/licenses/LICENSE-2.0
|
||||
!
|
||||
! Unless required by applicable law or agreed to in writing, software
|
||||
! distributed under the License is distributed on an "AS IS" BASIS,
|
||||
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
! See the License for the specific language governing permissions and
|
||||
! limitations under the License.
|
||||
|
||||
! Invalid operand types when user-defined operator is available
|
||||
module m1
|
||||
type :: t
|
||||
end type
|
||||
interface operator(==)
|
||||
logical function eq_tt(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
interface operator(+)
|
||||
logical function add_tr(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
real, intent(in) :: y
|
||||
end
|
||||
logical function plus_t(x)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
end
|
||||
logical function add_12(x, y)
|
||||
real, intent(in) :: x(:), y(:,:)
|
||||
end
|
||||
end interface
|
||||
interface operator(.and.)
|
||||
logical function and_tr(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x
|
||||
real, intent(in) :: y
|
||||
end
|
||||
end interface
|
||||
interface operator(//)
|
||||
logical function concat_tt(x, y)
|
||||
import :: t
|
||||
type(t), intent(in) :: x, y
|
||||
end
|
||||
end interface
|
||||
interface operator(.not.)
|
||||
logical function not_r(x)
|
||||
real, intent(in) :: x
|
||||
end
|
||||
end interface
|
||||
type(t) :: x, y
|
||||
real :: r
|
||||
logical :: l
|
||||
contains
|
||||
subroutine test_relational()
|
||||
l = x == y !OK
|
||||
l = x .eq. y !OK
|
||||
!ERROR: No user-defined or intrinsic == operator matches operand types TYPE(t) and REAL(4)
|
||||
l = x == r
|
||||
end
|
||||
subroutine test_numeric()
|
||||
l = x + r !OK
|
||||
!ERROR: No user-defined or intrinsic + operator matches operand types REAL(4) and TYPE(t)
|
||||
l = r + x
|
||||
end
|
||||
subroutine test_logical()
|
||||
l = x .and. r !OK
|
||||
!ERROR: No user-defined or intrinsic .AND. operator matches operand types REAL(4) and TYPE(t)
|
||||
l = r .and. x
|
||||
end
|
||||
subroutine test_unary()
|
||||
l = +x !OK
|
||||
!ERROR: No user-defined or intrinsic + operator matches operand type LOGICAL(4)
|
||||
l = +l
|
||||
l = .not. r !OK
|
||||
!ERROR: No user-defined or intrinsic .NOT. operator matches operand type TYPE(t)
|
||||
l = .not. x
|
||||
end
|
||||
subroutine test_concat()
|
||||
l = x // y !OK
|
||||
!ERROR: No user-defined or intrinsic // operator matches operand types TYPE(t) and REAL(4)
|
||||
l = x // r
|
||||
end
|
||||
subroutine test_conformability(x, y)
|
||||
real :: x(10), y(10,10)
|
||||
l = x + y !OK
|
||||
!ERROR: No user-defined or intrinsic + operator matches rank 2 array of REAL(4) and rank 1 array of REAL(4)
|
||||
l = y + x
|
||||
end
|
||||
end
|
||||
|
||||
! Invalid operand types when user-defined operator is not available
|
||||
module m2
|
||||
type :: t
|
||||
end type
|
||||
type(t) :: x, y
|
||||
real :: r
|
||||
logical :: l
|
||||
contains
|
||||
subroutine test_relational()
|
||||
!ERROR: Operands of == must have comparable types; have TYPE(t) and REAL(4)
|
||||
l = x == r
|
||||
end
|
||||
subroutine test_numeric()
|
||||
!ERROR: Operands of + must be numeric; have REAL(4) and TYPE(t)
|
||||
l = r + x
|
||||
end
|
||||
subroutine test_logical()
|
||||
!ERROR: Operands of .AND. must be LOGICAL; have REAL(4) and TYPE(t)
|
||||
l = r .and. x
|
||||
end
|
||||
subroutine test_unary()
|
||||
!ERROR: Operand of unary + must be numeric; have LOGICAL(4)
|
||||
l = +l
|
||||
!ERROR: Operand of .NOT. must be LOGICAL; have TYPE(t)
|
||||
l = .not. x
|
||||
end
|
||||
subroutine test_concat(a, b)
|
||||
character(4,kind=1) :: a
|
||||
character(4,kind=2) :: b
|
||||
character(4) :: c
|
||||
!ERROR: Operands of // must be CHARACTER with the same kind; have CHARACTER(KIND=1) and CHARACTER(KIND=2)
|
||||
c = a // b
|
||||
!ERROR: Operands of // must be CHARACTER with the same kind; have TYPE(t) and REAL(4)
|
||||
l = x // r
|
||||
end
|
||||
subroutine test_conformability(x, y)
|
||||
real :: x(10), y(10,10)
|
||||
!ERROR: Operands of + are not conformable; have rank 2 and rank 1
|
||||
l = y + x
|
||||
end
|
||||
end
|
||||
|
||||
! Invalid untyped operands: user-defined operator doesn't affect errors
|
||||
module m3
|
||||
interface operator(+)
|
||||
logical function add(x, y)
|
||||
logical :: x
|
||||
integer :: y
|
||||
end
|
||||
end interface
|
||||
contains
|
||||
subroutine s1(x, y)
|
||||
logical :: x
|
||||
integer :: y
|
||||
logical :: l
|
||||
y = y + z'1' !OK
|
||||
y = +z'1' !OK
|
||||
!ERROR: Operands of + must be numeric; have LOGICAL(4) and untyped
|
||||
y = x + z'1'
|
||||
!ERROR: Operands of /= must have comparable types; have LOGICAL(4) and untyped
|
||||
l = x /= null()
|
||||
end
|
||||
end
|
Loading…
Reference in New Issue