in flang/lib/Evaluate/intrinsics.cpp [1200:1847]
std::optional<SpecificCall> IntrinsicInterface::Match(
const CallCharacteristics &call,
const common::IntrinsicTypeDefaultKinds &defaults,
ActualArguments &arguments, FoldingContext &context,
const semantics::Scope *builtinsScope) const {
auto &messages{context.messages()};
// Attempt to construct a 1-1 correspondence between the dummy arguments in
// a particular intrinsic procedure's generic interface and the actual
// arguments in a procedure reference.
std::size_t dummyArgPatterns{0};
for (; dummyArgPatterns < maxArguments && dummy[dummyArgPatterns].keyword;
++dummyArgPatterns) {
}
// MAX and MIN (and others that map to them) allow their last argument to
// be repeated indefinitely. The actualForDummy vector is sized
// and null-initialized to the non-repeated dummy argument count
// for other instrinsics.
bool isMaxMin{dummyArgPatterns > 0 &&
dummy[dummyArgPatterns - 1].optionality == Optionality::repeats};
std::vector<ActualArgument *> actualForDummy(
isMaxMin ? 0 : dummyArgPatterns, nullptr);
int missingActualArguments{0};
std::set<parser::CharBlock> maxMinKeywords;
for (std::optional<ActualArgument> &arg : arguments) {
if (!arg) {
++missingActualArguments;
} else if (arg->isAlternateReturn()) {
messages.Say(
"alternate return specifier not acceptable on call to intrinsic '%s'"_err_en_US,
name);
return std::nullopt;
} else if (isMaxMin) {
if (CheckMaxMinArgument(arg->keyword(), maxMinKeywords, name, messages)) {
actualForDummy.push_back(&*arg);
} else {
return std::nullopt;
}
} else {
bool found{false};
int slot{missingActualArguments};
for (std::size_t j{0}; j < dummyArgPatterns && !found; ++j) {
if (dummy[j].optionality == Optionality::missing) {
continue;
}
if (arg->keyword()) {
found = *arg->keyword() == dummy[j].keyword;
if (found) {
if (const auto *previous{actualForDummy[j]}) {
if (previous->keyword()) {
messages.Say(*arg->keyword(),
"repeated keyword argument to intrinsic '%s'"_err_en_US,
name);
} else {
messages.Say(*arg->keyword(),
"keyword argument to intrinsic '%s' was supplied "
"positionally by an earlier actual argument"_err_en_US,
name);
}
return std::nullopt;
}
}
} else {
found = !actualForDummy[j] && slot-- == 0;
}
if (found) {
actualForDummy[j] = &*arg;
}
}
if (!found) {
if (arg->keyword()) {
messages.Say(*arg->keyword(),
"unknown keyword argument to intrinsic '%s'"_err_en_US, name);
} else {
messages.Say(
"too many actual arguments for intrinsic '%s'"_err_en_US, name);
}
return std::nullopt;
}
}
}
std::size_t dummies{actualForDummy.size()};
// Check types and kinds of the actual arguments against the intrinsic's
// interface. Ensure that two or more arguments that have to have the same
// (or compatible) type and kind do so. Check for missing non-optional
// arguments now, too.
const ActualArgument *sameArg{nullptr};
const ActualArgument *operandArg{nullptr};
const IntrinsicDummyArgument *kindDummyArg{nullptr};
const ActualArgument *kindArg{nullptr};
bool hasDimArg{false};
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (d.typePattern.kindCode == KindCode::kindArg) {
CHECK(!kindDummyArg);
kindDummyArg = &d;
}
const ActualArgument *arg{actualForDummy[j]};
if (!arg) {
if (d.optionality == Optionality::required) {
messages.Say("missing mandatory '%s=' argument"_err_en_US, d.keyword);
return std::nullopt; // missing non-OPTIONAL argument
} else {
continue;
}
} else if (d.optionality == Optionality::missing) {
messages.Say("unexpected '%s=' argument"_err_en_US, d.keyword);
return std::nullopt;
}
if (arg->GetAssumedTypeDummy()) {
// TYPE(*) assumed-type dummy argument forwarded to intrinsic
if (d.typePattern.categorySet == AnyType &&
d.rank == Rank::anyOrAssumedRank &&
(d.typePattern.kindCode == KindCode::any ||
d.typePattern.kindCode == KindCode::addressable)) {
continue;
} else {
messages.Say("Assumed type TYPE(*) dummy argument not allowed "
"for '%s=' intrinsic argument"_err_en_US,
d.keyword);
return std::nullopt;
}
}
std::optional<DynamicType> type{arg->GetType()};
if (!type) {
CHECK(arg->Rank() == 0);
const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())};
if (IsBOZLiteral(expr)) {
if (d.typePattern.kindCode == KindCode::typeless ||
d.rank == Rank::elementalOrBOZ) {
continue;
} else {
const IntrinsicDummyArgument &nextParam{dummy[j + 1]};
messages.Say(
"Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109
d.keyword, nextParam.keyword);
}
} else {
// NULL(), procedure, or procedure pointer
CHECK(IsProcedurePointerTarget(expr));
if (d.typePattern.kindCode == KindCode::addressable ||
d.rank == Rank::reduceOperation) {
continue;
} else if (d.typePattern.kindCode == KindCode::nullPointerType) {
continue;
} else {
messages.Say(
"Actual argument for '%s=' may not be a procedure"_err_en_US,
d.keyword);
}
}
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category())) {
messages.Say("Actual argument for '%s=' has bad type '%s'"_err_en_US,
d.keyword, type->AsFortran());
return std::nullopt; // argument has invalid type category
}
bool argOk{false};
switch (d.typePattern.kindCode) {
case KindCode::none:
case KindCode::typeless:
argOk = false;
break;
case KindCode::teamType:
argOk = !type->IsUnlimitedPolymorphic() &&
type->category() == TypeCategory::Derived &&
semantics::IsTeamType(&type->GetDerivedTypeSpec());
break;
case KindCode::defaultIntegerKind:
argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer);
break;
case KindCode::defaultRealKind:
argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Real);
break;
case KindCode::doublePrecision:
argOk = type->kind() == defaults.doublePrecisionKind();
break;
case KindCode::defaultCharKind:
argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Character);
break;
case KindCode::defaultLogicalKind:
argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Logical);
break;
case KindCode::any:
argOk = true;
break;
case KindCode::kindArg:
CHECK(type->category() == TypeCategory::Integer);
CHECK(!kindArg);
kindArg = arg;
argOk = true;
break;
case KindCode::dimArg:
CHECK(type->category() == TypeCategory::Integer);
hasDimArg = true;
argOk = true;
break;
case KindCode::same:
if (!sameArg) {
sameArg = arg;
}
argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
break;
case KindCode::operand:
if (!operandArg) {
operandArg = arg;
} else if (auto prev{operandArg->GetType()}) {
if (type->category() == prev->category()) {
if (type->kind() > prev->kind()) {
operandArg = arg;
}
} else if (prev->category() == TypeCategory::Integer) {
operandArg = arg;
}
}
argOk = true;
break;
case KindCode::effectiveKind:
common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' "
"for intrinsic '%s'",
d.keyword, name);
break;
case KindCode::addressable:
case KindCode::nullPointerType:
argOk = true;
break;
default:
CRASH_NO_CASE;
}
if (!argOk) {
messages.Say(
"Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
d.keyword, type->AsFortran());
return std::nullopt;
}
}
// Check the ranks of the arguments against the intrinsic's interface.
const ActualArgument *arrayArg{nullptr};
const char *arrayArgName{nullptr};
const ActualArgument *knownArg{nullptr};
std::optional<int> shapeArgSize;
int elementalRank{0};
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const ActualArgument * arg{actualForDummy[j]}) {
bool isAssumedRank{IsAssumedRank(*arg)};
if (isAssumedRank && d.rank != Rank::anyOrAssumedRank) {
messages.Say("Assumed-rank array cannot be forwarded to "
"'%s=' argument"_err_en_US,
d.keyword);
return std::nullopt;
}
int rank{arg->Rank()};
bool argOk{false};
switch (d.rank) {
case Rank::elemental:
case Rank::elementalOrBOZ:
if (elementalRank == 0) {
elementalRank = rank;
}
argOk = rank == 0 || rank == elementalRank;
break;
case Rank::scalar:
argOk = rank == 0;
break;
case Rank::vector:
argOk = rank == 1;
break;
case Rank::shape:
CHECK(!shapeArgSize);
if (rank != 1) {
messages.Say(
"'shape=' argument must be an array of rank 1"_err_en_US);
return std::nullopt;
} else {
if (auto shape{GetShape(context, *arg)}) {
if (auto constShape{AsConstantShape(context, *shape)}) {
shapeArgSize = constShape->At(ConstantSubscripts{1}).ToInt64();
CHECK(shapeArgSize >= 0);
argOk = true;
}
}
}
if (!argOk) {
messages.Say(
"'shape=' argument must be a vector of known size"_err_en_US);
return std::nullopt;
}
break;
case Rank::matrix:
argOk = rank == 2;
break;
case Rank::array:
argOk = rank > 0;
if (!arrayArg) {
arrayArg = arg;
arrayArgName = d.keyword;
} else {
argOk &= rank == arrayArg->Rank();
}
break;
case Rank::coarray:
argOk = IsCoarray(*arg);
if (!argOk) {
messages.Say(
"'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US,
name);
return std::nullopt;
}
break;
case Rank::known:
if (!knownArg) {
knownArg = arg;
}
argOk = rank == knownArg->Rank();
break;
case Rank::anyOrAssumedRank:
if (!hasDimArg && rank > 0 && !isAssumedRank &&
(std::strcmp(name, "shape") == 0 ||
std::strcmp(name, "size") == 0 ||
std::strcmp(name, "ubound") == 0)) {
// Check for an assumed-size array argument.
// These are disallowed for SHAPE, and require DIM= for
// SIZE and UBOUND.
// (A previous error message for UBOUND will take precedence
// over this one, as this error is caught by the second entry
// for UBOUND.)
if (std::optional<Shape> shape{GetShape(context, *arg)}) {
if (!shape->empty() && !shape->back().has_value()) {
if (strcmp(name, "shape") == 0) {
messages.Say(
"The '%s=' argument to the intrinsic function '%s' may not be assumed-size"_err_en_US,
d.keyword, name);
} else {
messages.Say(
"A dim= argument is required for '%s' when the array is assumed-size"_err_en_US,
name);
}
return std::nullopt;
}
}
}
argOk = true;
break;
case Rank::conformable: // arg must be conformable with previous arrayArg
CHECK(arrayArg);
CHECK(arrayArgName);
if (const std::optional<Shape> &arrayArgShape{
GetShape(context, *arrayArg)}) {
if (std::optional<Shape> argShape{GetShape(context, *arg)}) {
std::string arrayArgMsg{"'"};
arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument";
std::string argMsg{"'"};
argMsg = argMsg + d.keyword + "='" + " argument";
CheckConformance(context.messages(), *arrayArgShape, *argShape,
CheckConformanceFlags::RightScalarExpandable,
arrayArgMsg.c_str(), argMsg.c_str());
}
}
argOk = true; // Avoid an additional error message
break;
case Rank::dimReduced:
case Rank::dimRemovedOrScalar:
CHECK(arrayArg);
argOk = rank == 0 || rank + 1 == arrayArg->Rank();
break;
case Rank::reduceOperation:
// TODO: validate the reduction operation -- it must be a pure
// function of two arguments with special constraints.
CHECK(arrayArg);
argOk = rank == 0;
break;
case Rank::locReduced:
case Rank::rankPlus1:
case Rank::shaped:
common::die("INTERNAL: result-only rank code appears on argument '%s' "
"for intrinsic '%s'",
d.keyword, name);
}
if (!argOk) {
messages.Say("'%s=' argument has unacceptable rank %d"_err_en_US,
d.keyword, rank);
return std::nullopt;
}
}
}
// Calculate the characteristics of the function result, if any
std::optional<DynamicType> resultType;
if (auto category{result.categorySet.LeastElement()}) {
// The intrinsic is not a subroutine.
if (call.isSubroutineCall) {
return std::nullopt;
}
switch (result.kindCode) {
case KindCode::defaultIntegerKind:
CHECK(result.categorySet == IntType);
CHECK(*category == TypeCategory::Integer);
resultType = DynamicType{TypeCategory::Integer,
defaults.GetDefaultKind(TypeCategory::Integer)};
break;
case KindCode::defaultRealKind:
CHECK(result.categorySet == CategorySet{*category});
CHECK(FloatingType.test(*category));
resultType =
DynamicType{*category, defaults.GetDefaultKind(TypeCategory::Real)};
break;
case KindCode::doublePrecision:
CHECK(result.categorySet == CategorySet{*category});
CHECK(FloatingType.test(*category));
resultType = DynamicType{*category, defaults.doublePrecisionKind()};
break;
case KindCode::defaultLogicalKind:
CHECK(result.categorySet == LogicalType);
CHECK(*category == TypeCategory::Logical);
resultType = DynamicType{TypeCategory::Logical,
defaults.GetDefaultKind(TypeCategory::Logical)};
break;
case KindCode::same:
CHECK(sameArg);
if (std::optional<DynamicType> aType{sameArg->GetType()}) {
if (result.categorySet.test(aType->category())) {
resultType = *aType;
} else {
resultType = DynamicType{*category, aType->kind()};
}
}
break;
case KindCode::operand:
CHECK(operandArg);
resultType = operandArg->GetType();
CHECK(!resultType || result.categorySet.test(resultType->category()));
break;
case KindCode::effectiveKind:
CHECK(kindDummyArg);
CHECK(result.categorySet == CategorySet{*category});
if (kindArg) {
if (auto *expr{kindArg->UnwrapExpr()}) {
CHECK(expr->Rank() == 0);
if (auto code{ToInt64(*expr)}) {
if (IsValidKindOfIntrinsicType(*category, *code)) {
if (*category == TypeCategory::Character) { // ACHAR & CHAR
resultType = DynamicType{static_cast<int>(*code), 1};
} else {
resultType = DynamicType{*category, static_cast<int>(*code)};
}
break;
}
}
}
messages.Say("'kind=' argument must be a constant scalar integer "
"whose value is a supported kind for the "
"intrinsic result type"_err_en_US);
return std::nullopt;
} else if (kindDummyArg->optionality == Optionality::defaultsToSameKind) {
CHECK(sameArg);
resultType = *sameArg->GetType();
} else if (kindDummyArg->optionality == Optionality::defaultsToSizeKind) {
CHECK(*category == TypeCategory::Integer);
resultType =
DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()};
} else {
CHECK(kindDummyArg->optionality ==
Optionality::defaultsToDefaultForResult);
int kind{defaults.GetDefaultKind(*category)};
if (*category == TypeCategory::Character) { // ACHAR & CHAR
resultType = DynamicType{kind, 1};
} else {
resultType = DynamicType{*category, kind};
}
}
break;
case KindCode::likeMultiply:
CHECK(dummies >= 2);
CHECK(actualForDummy[0]);
CHECK(actualForDummy[1]);
resultType = actualForDummy[0]->GetType()->ResultTypeForMultiply(
*actualForDummy[1]->GetType());
break;
case KindCode::subscript:
CHECK(result.categorySet == IntType);
CHECK(*category == TypeCategory::Integer);
resultType =
DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()};
break;
case KindCode::size:
CHECK(result.categorySet == IntType);
CHECK(*category == TypeCategory::Integer);
resultType =
DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()};
break;
case KindCode::teamType:
CHECK(result.categorySet == DerivedType);
CHECK(*category == TypeCategory::Derived);
resultType = DynamicType{
GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")};
break;
case KindCode::defaultCharKind:
case KindCode::typeless:
case KindCode::any:
case KindCode::kindArg:
case KindCode::dimArg:
common::die(
"INTERNAL: bad KindCode appears on intrinsic '%s' result", name);
break;
default:
CRASH_NO_CASE;
}
} else {
if (!call.isSubroutineCall) {
return std::nullopt;
}
CHECK(result.kindCode == KindCode::none);
}
// At this point, the call is acceptable.
// Determine the rank of the function result.
int resultRank{0};
switch (rank) {
case Rank::elemental:
resultRank = elementalRank;
break;
case Rank::scalar:
resultRank = 0;
break;
case Rank::vector:
resultRank = 1;
break;
case Rank::matrix:
resultRank = 2;
break;
case Rank::conformable:
CHECK(arrayArg);
resultRank = arrayArg->Rank();
break;
case Rank::dimReduced:
CHECK(arrayArg);
resultRank = hasDimArg ? arrayArg->Rank() - 1 : 0;
break;
case Rank::locReduced:
CHECK(arrayArg);
resultRank = hasDimArg ? arrayArg->Rank() - 1 : 1;
break;
case Rank::rankPlus1:
CHECK(knownArg);
resultRank = knownArg->Rank() + 1;
break;
case Rank::shaped:
CHECK(shapeArgSize);
resultRank = *shapeArgSize;
break;
case Rank::elementalOrBOZ:
case Rank::shape:
case Rank::array:
case Rank::coarray:
case Rank::known:
case Rank::anyOrAssumedRank:
case Rank::reduceOperation:
case Rank::dimRemovedOrScalar:
common::die("INTERNAL: bad Rank code on intrinsic '%s' result", name);
break;
}
CHECK(resultRank >= 0);
// Rearrange the actual arguments into dummy argument order.
ActualArguments rearranged(dummies);
for (std::size_t j{0}; j < dummies; ++j) {
if (ActualArgument * arg{actualForDummy[j]}) {
rearranged[j] = std::move(*arg);
}
}
// Characterize the specific intrinsic procedure.
characteristics::DummyArguments dummyArgs;
std::optional<int> sameDummyArg;
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
std::string kw{d.keyword};
if (isMaxMin) {
kw = "a"s + std::to_string(j + 1);
}
auto dc{characteristics::DummyArgument::FromActual(
std::move(kw), *expr, context)};
if (!dc) {
common::die("INTERNAL: could not characterize intrinsic function "
"actual argument '%s'",
expr->AsFortran().c_str());
return std::nullopt;
}
dummyArgs.emplace_back(std::move(*dc));
if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
sameDummyArg = j;
}
} else {
CHECK(arg->GetAssumedTypeDummy());
dummyArgs.emplace_back(std::string{d.keyword},
characteristics::DummyDataObject{DynamicType::AssumedType()});
}
} else {
// optional argument is absent
CHECK(d.optionality != Optionality::required);
if (d.typePattern.kindCode == KindCode::same) {
dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]);
} else {
auto category{d.typePattern.categorySet.LeastElement().value()};
if (category == TypeCategory::Derived) {
// TODO: any other built-in derived types used as optional intrinsic
// dummies?
CHECK(d.typePattern.kindCode == KindCode::teamType);
characteristics::TypeAndShape typeAndShape{
GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")};
dummyArgs.emplace_back(std::string{d.keyword},
characteristics::DummyDataObject{std::move(typeAndShape)});
} else {
characteristics::TypeAndShape typeAndShape{
DynamicType{category, defaults.GetDefaultKind(category)}};
dummyArgs.emplace_back(std::string{d.keyword},
characteristics::DummyDataObject{std::move(typeAndShape)});
}
}
dummyArgs.back().SetOptional();
}
dummyArgs.back().SetIntent(d.intent);
}
characteristics::Procedure::Attrs attrs;
if (elementalRank > 0) {
attrs.set(characteristics::Procedure::Attr::Elemental);
}
if (call.isSubroutineCall) {
return SpecificCall{
SpecificIntrinsic{
name, characteristics::Procedure{std::move(dummyArgs), attrs}},
std::move(rearranged)};
} else {
attrs.set(characteristics::Procedure::Attr::Pure);
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
characteristics::Procedure chars{
std::move(funcResult), std::move(dummyArgs), attrs};
return SpecificCall{
SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)};
}
}