[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:
Tim Keith 2019-11-02 09:56:46 -07:00
parent 41aa3bf7a4
commit dce7f0aca0
11 changed files with 1134 additions and 176 deletions

View File

@ -13,6 +13,7 @@
# limitations under the License.
add_library(FortranCommon
Fortran.cc
default-kinds.cc
idioms.cc
)

View File

@ -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."};
}
}
}

View File

@ -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)

View File

@ -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>,

View File

@ -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>

View File

@ -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>>{};
},
},

View File

@ -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 {

View File

@ -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>

View File

@ -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

View File

@ -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

View File

@ -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