maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] checkpoint, all tests pass 

Fix name resolution for undeclared intrinsic actual arguments

Original-commit: flang-compiler/f18@12470f06bc
Reviewed-on: https://github.com/flang-compiler/f18/pull/818
This commit is contained in:
peter klausler 2019-11-07 16:01:38 -08:00
parent f638549d8c
commit 6c9b8845e9
18 changed files with 467 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
flang/lib/evaluate/characteristics.cc
View File

@ -40,8 +40,33 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst,
}
}
// Shapes of function results and dummy arguments have to have
// the same rank, the same deferred dimensions, and the same
// values for explicit dimensions when constant.
static bool ShapesAreCompatible(const Shape &x, const Shape &y) {
if (x.size() != y.size()) {
return false;
}
auto yIter{y.begin()};
for (const auto &xDim : x) {
const auto &yDim{*yIter++};
if (xDim.has_value() != yDim.has_value()) {
return false;
}
if (xDim) {
auto xConst{ToInt64(*xDim)};
auto yConst{ToInt64(*yDim)};
if (xConst.has_value() != yConst.has_value() ||
(xConst && *xConst != *yConst)) {
return false;
}
}
}
return true;
}
bool TypeAndShape::operator==(const TypeAndShape &that) const {
return type_ == that.type_ && shape_ == that.shape_ &&
return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) &&
attrs_ == that.attrs_ && corank_ == that.corank_;
}
@ -214,6 +239,18 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
coshape == that.coshape;
}
static common::Intent GetIntent(const semantics::Attrs &attrs) {
if (attrs.test(semantics::Attr::INTENT_IN)) {
return common::Intent::In;
} else if (attrs.test(semantics::Attr::INTENT_OUT)) {
return common::Intent::Out;
} else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
return common::Intent::InOut;
} else {
return common::Intent::Default;
}
}
std::optional<DummyDataObject> DummyDataObject::Characterize(
const semantics::Symbol &symbol) {
if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
@ -231,17 +268,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::POINTER, DummyDataObject::Attr::Pointer},
{Attr::TARGET, DummyDataObject::Attr::Target},
});
if (symbol.attrs().test(semantics::Attr::INTENT_IN)) {
result->intent = common::Intent::In;
}
if (symbol.attrs().test(semantics::Attr::INTENT_OUT)) {
CHECK(result->intent == common::Intent::Default);
result->intent = common::Intent::Out;
}
if (symbol.attrs().test(semantics::Attr::INTENT_INOUT)) {
CHECK(result->intent == common::Intent::Default);
result->intent = common::Intent::InOut;
}
result->intent = GetIntent(symbol.attrs());
return result;
}
}
@ -290,18 +317,25 @@ DummyProcedure::DummyProcedure(Procedure &&p)
: procedure{new Procedure{std::move(p)}} {}
bool DummyProcedure::operator==(const DummyProcedure &that) const {
return attrs == that.attrs && procedure.value() == that.procedure.value();
return attrs == that.attrs && intent == that.intent &&
procedure.value() == that.procedure.value();
}
std::optional<DummyProcedure> DummyProcedure::Characterize(
const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) {
// Dummy procedures may not be elemental. Elemental dummy procedure
// interfaces are errors when the interface is not intrinsic, and that
// error is caught elsewhere. Elemental intrinsic interfaces are
// made non-elemental.
procedure->attrs.reset(Procedure::Attr::Elemental);
DummyProcedure result{std::move(procedure.value())};
CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
{
{semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
{semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
});
result.intent = GetIntent(symbol.attrs());
return result;
} else {
return std::nullopt;
@ -310,6 +344,9 @@ std::optional<DummyProcedure> DummyProcedure::Characterize(
std::ostream &DummyProcedure::Dump(std::ostream &o) const {
attrs.Dump(o, EnumToString);
if (intent != common::Intent::Default) {
o << "INTENT(" << common::EnumToString(intent) << ')';
}
procedure.value().Dump(o);
return o;
}
@ -542,14 +579,17 @@ std::optional<Procedure> Procedure::Characterize(
[&](const semantics::SubprogramDetails &subp)
-> std::optional<Procedure> {
if (subp.isFunction()) {
auto fr{FunctionResult::Characterize(subp.result(), intrinsics)};
if (!fr) {
if (auto fr{FunctionResult::Characterize(
subp.result(), intrinsics)}) {
result.functionResult = std::move(fr);
} else {
return std::nullopt;
}
result.functionResult = std::move(fr);
} else {
result.attrs.set(Attr::Subroutine);
}
for (const semantics::Symbol *arg : subp.dummyArgs()) {
if (arg == nullptr) {
if (!arg) {
result.dummyArguments.emplace_back(AlternateReturn{});
} else if (auto argCharacteristics{
DummyArgument::Characterize(*arg, intrinsics)}) {
@ -571,20 +611,19 @@ std::optional<Procedure> Procedure::Characterize(
if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
return Characterize(*interfaceSymbol, intrinsics);
} else {
result.attrs.set(Procedure::Attr::ImplicitInterface);
result.attrs.set(Attr::ImplicitInterface);
const semantics::DeclTypeSpec *type{interface.type()};
if (symbol.test(semantics::Symbol::Flag::Function)) {
if (type != nullptr) {
if (auto resultType{DynamicType::From(*type)}) {
result.functionResult = FunctionResult{*resultType};
}
if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
// ignore any implicit typing
result.attrs.set(Attr::Subroutine);
} else if (type) {
if (auto resultType{DynamicType::From(*type)}) {
result.functionResult = FunctionResult{*resultType};
} else {
return std::nullopt;
}
} else { // subroutine, not function
if (type != nullptr) {
return std::nullopt;
}
} else if (symbol.test(semantics::Symbol::Flag::Function)) {
return std::nullopt;
}
// The PASS name, if any, is not a characteristic.
return result;
@ -630,7 +669,15 @@ std::optional<Procedure> Procedure::Characterize(
std::optional<Procedure> Procedure::Characterize(
const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
return Characterize(ref.proc(), intrinsics);
if (auto callee{Characterize(ref.proc(), intrinsics)}) {
if (callee->functionResult) {
if (const Procedure *
proc{callee->functionResult->IsProcedurePointer()}) {
return {*proc};
}
}
}
return std::nullopt;
}
bool Procedure::CanBeCalledViaImplicitInterface() const {

24
flang/lib/evaluate/characteristics.h
View File

@ -74,6 +74,7 @@ public:
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape)
bool operator==(const TypeAndShape &) const;
bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
static std::optional<TypeAndShape> Characterize(const semantics::Symbol &);
static std::optional<TypeAndShape> Characterize(
const semantics::ObjectEntityDetails &);
@ -129,6 +130,9 @@ struct DummyDataObject {
explicit DummyDataObject(TypeAndShape &&t) : type{std::move(t)} {}
explicit DummyDataObject(DynamicType t) : type{t} {}
bool operator==(const DummyDataObject &) const;
bool operator!=(const DummyDataObject &that) const {
return !(*this == that);
}
static std::optional<DummyDataObject> Characterize(const semantics::Symbol &);
bool CanBePassedViaImplicitInterface() const;
std::ostream &Dump(std::ostream &) const;
@ -141,19 +145,23 @@ struct DummyDataObject {
// 15.3.2.3
struct DummyProcedure {
ENUM_CLASS(Attr, Pointer, Optional)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
explicit DummyProcedure(Procedure &&);
bool operator==(const DummyProcedure &) const;
bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
static std::optional<DummyProcedure> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);
std::ostream &Dump(std::ostream &) const;
CopyableIndirection<Procedure> procedure;
common::EnumSet<Attr, Attr_enumSize> attrs;
common::Intent intent{common::Intent::Default};
Attrs attrs;
};
// 15.3.2.4
struct AlternateReturn {
bool operator==(const AlternateReturn &) const { return true; }
bool operator!=(const AlternateReturn &) const { return false; }
std::ostream &Dump(std::ostream &) const;
};
@ -167,6 +175,7 @@ struct DummyArgument {
explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {}
~DummyArgument();
bool operator==(const DummyArgument &) const;
bool operator!=(const DummyArgument &that) const { return !(*this == that); }
static std::optional<DummyArgument> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);
static std::optional<DummyArgument> FromActual(
@ -187,12 +196,14 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
explicit FunctionResult(DynamicType);
explicit FunctionResult(TypeAndShape &&);
explicit FunctionResult(Procedure &&);
~FunctionResult();
bool operator==(const FunctionResult &) const;
bool operator!=(const FunctionResult &that) const { return !(*this == that); }
static std::optional<FunctionResult> Characterize(
const Symbol &, const IntrinsicProcTable &);
@ -213,19 +224,21 @@ struct FunctionResult {
std::ostream &Dump(std::ostream &) const;
common::EnumSet<Attr, Attr_enumSize> attrs;
Attrs attrs;
std::variant<TypeAndShape, CopyableIndirection<Procedure>> u;
};
// 15.3.1
struct Procedure {
ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer)
ENUM_CLASS(
Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, Subroutine)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
Procedure(FunctionResult &&, DummyArguments &&, Attrs);
Procedure(DummyArguments &&, Attrs); // for subroutines and NULL()
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
~Procedure();
bool operator==(const Procedure &) const;
bool operator!=(const Procedure &that) const { return !(*this == that); }
// Characterizes the procedure represented by a symbol, which may be an
// "unrestricted specific intrinsic function".
@ -236,8 +249,11 @@ struct Procedure {
static std::optional<Procedure> Characterize(
const ProcedureRef &, const IntrinsicProcTable &);
// At most one of these will return true.
// For "EXTERNAL P" with no calls to P, both will be false.
bool IsFunction() const { return functionResult.has_value(); }
bool IsSubroutine() const { return !IsFunction(); }
bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
bool IsPure() const { return attrs.test(Attr::Pure); }
bool IsElemental() const { return attrs.test(Attr::Elemental); }
bool IsBindC() const { return attrs.test(Attr::BindC); }

2
flang/lib/evaluate/fold.cc
View File

@ -924,7 +924,7 @@ Expr<Type<TypeCategory::Real, KIND>> ToReal(
CHECK(constant != nullptr);
Scalar<Result> real{constant->GetScalarValue().value()};
From converted{From::ConvertUnsigned(real.RawBits()).value};
if (!(original == converted)) { // C1601
if (original != converted) { // C1601
context.messages().Say(
"Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_en_US);
}

3
flang/lib/evaluate/integer.h
View File

@ -184,6 +184,9 @@ public:
constexpr bool operator==(const Integer &that) const {
return CompareUnsigned(that) == Ordering::Equal;
}
constexpr bool operator!=(const Integer &that) const {
return !(*this == that);
}
// Left-justified mask (e.g., MASKL(1) has only its sign bit set)
static constexpr Integer MASKL(int places) {

4
flang/lib/evaluate/intrinsics.cc
View File

@ -474,8 +474,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
{"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
{"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical},
{"loc", {{"x", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt,
Rank::scalar},
{"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}},
SubscriptInt, Rank::scalar},
{"log", {{"x", SameFloating}}, SameFloating},
{"log10", {{"x", SameReal}}, SameReal},
{"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical},

5
flang/lib/evaluate/tools.cc
View File

@ -638,7 +638,10 @@ bool IsAssumedRank(const ActualArgument &arg) {
}
}
// IsProcedurePointer()
bool IsProcedure(const Expr<SomeType> &expr) {
return std::holds_alternative<ProcedureDesignator>(expr.u);
}
bool IsProcedurePointer(const Expr<SomeType> &expr) {
return std::visit(
common::visitors{

3
flang/lib/evaluate/tools.h
View File

@ -761,7 +761,8 @@ template<typename A> bool IsAllocatableOrPointer(const A &x) {
semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
}
// Pointer detection predicates
// Procedure and pointer detection predicates
bool IsProcedure(const Expr<SomeType> &);
bool IsProcedurePointer(const Expr<SomeType> &);
bool IsNullPointer(const Expr<SomeType> &);

7
flang/lib/parser/grammar.h
View File

@ -999,6 +999,9 @@ TYPE_PARSER(construct<AcImpliedDoControl>(
// R801 type-declaration-stmt ->
// declaration-type-spec [[, attr-spec]... ::] entity-decl-list
constexpr auto entityDeclWithoutEqInit{construct<EntityDecl>(name,
maybe(arraySpec), maybe(coarraySpec), maybe("*" >> charLength),
!"="_tok >> maybe(initialization))}; // old-style REAL A/0/ still works
TYPE_PARSER(
construct<TypeDeclarationStmt>(declarationTypeSpec,
defaulted("," >> nonemptyList(Parser<AttrSpec>{})) / "::",
@ -1006,8 +1009,8 @@ TYPE_PARSER(
// C806: no initializers allowed without colons ("REALA=1" is ambiguous)
construct<TypeDeclarationStmt>(declarationTypeSpec,
construct<std::list<AttrSpec>>(),
nonemptyList(
"expected entity declarations"_err_en_US, entityDeclWithoutInit)) ||
nonemptyList("expected entity declarations"_err_en_US,
entityDeclWithoutEqInit)) ||
// PGI-only extension: comma in place of doubled colons
extension<LanguageFeature::MissingColons>(construct<TypeDeclarationStmt>(
declarationTypeSpec, defaulted("," >> nonemptyList(Parser<AttrSpec>{})),

2
flang/lib/parser/type-parsers.h
View File

@ -87,7 +87,7 @@ constexpr Parser<TypeDeclarationStmt> typeDeclarationStmt; // R801
constexpr Parser<NullInit> nullInit; // R806
constexpr Parser<AccessSpec> accessSpec; // R807
constexpr Parser<LanguageBindingSpec> languageBindingSpec; // R808, R1528
constexpr Parser<EntityDecl> entityDecl, entityDeclWithoutInit; // R803
constexpr Parser<EntityDecl> entityDecl; // R803
constexpr Parser<CoarraySpec> coarraySpec; // R809
constexpr Parser<ArraySpec> arraySpec; // R815
constexpr Parser<ExplicitShapeSpec> explicitShapeSpec; // R816

40
flang/lib/semantics/assignment.cc
View File

@ -40,8 +40,7 @@ public:
const std::string &description, const characteristics::TypeAndShape *type,
parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics,
const std::optional<characteristics::Procedure> &procedure,
bool isContiguous)
const characteristics::Procedure *procedure, bool isContiguous)
: pointer_{pointer}, source_{source}, description_{description},
type_{type}, messages_{messages}, intrinsics_{intrinsics},
procedure_{procedure}, isContiguous_{isContiguous} {}
@ -71,12 +70,12 @@ public:
std::optional<parser::MessageFixedText> error;
if (const auto &funcResult{proc->functionResult}) { // C1025
const auto *frProc{funcResult->IsProcedurePointer()};
if (procedure_.has_value()) {
if (procedure_) {
// Shouldn't be here in this function unless lhs
// is an object pointer.
error =
"Procedure %s is associated with the result of a reference to function '%s' that does not return a procedure pointer"_err_en_US;
} else if (frProc != nullptr) {
} else if (frProc) {
error =
"Object %s is associated with the result of a reference to function '%s' that is a procedure pointer"_err_en_US;
} else if (!funcResult->attrs.test(
@ -90,7 +89,7 @@ public:
"CONTIGUOUS %s is associated with the result of reference to function '%s' that is not contiguous"_err_en_US;
} else if (type_) {
const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
CHECK(frTypeAndShape != nullptr);
CHECK(frTypeAndShape);
if (!type_->IsCompatibleWith(messages_, *frTypeAndShape)) {
error =
"%s is associated with the result of a reference to function '%s' whose pointer result has an incompatible type or shape"_err_en_US;
@ -110,14 +109,14 @@ public:
template<typename T> void Check(const Designator<T> &d) {
const Symbol *last{d.GetLastSymbol()};
const Symbol *base{d.GetBaseObject().symbol()};
if (last != nullptr && base != nullptr) {
if (last && base) {
std::optional<parser::MessageFixedText> error;
if (procedure_.has_value()) {
if (procedure_) {
// Shouldn't be here in this function unless lhs is an
// object pointer.
error =
"In assignment to procedure %s, the target is not a procedure or procedure pointer"_err_en_US;
} else if (GetLastTarget(GetSymbolVector(d)) == nullptr) { // C1025
} else if (!GetLastTarget(GetSymbolVector(d))) { // C1025
error =
"In assignment to object %s, the target '%s' is not an object with POINTER or TARGET attributes"_err_en_US;
} else if (auto rhsTypeAndShape{
@ -161,7 +160,7 @@ private:
const characteristics::TypeAndShape *type_{nullptr};
parser::ContextualMessages &messages_;
const IntrinsicProcTable &intrinsics_;
const std::optional<characteristics::Procedure> &procedure_;
const characteristics::Procedure *procedure_{nullptr};
bool isContiguous_{false};
};
@ -178,9 +177,9 @@ void PointerAssignmentChecker::Check(const Expr<SomeType> &rhs) {
// Common handling for procedure pointer right-hand sides
void PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
const characteristics::Procedure *targetChars) {
if (procedure_.has_value()) {
if (targetChars != nullptr) {
if (!(*procedure_ == *targetChars)) {
if (procedure_) {
if (targetChars) {
if (*procedure_ != *targetChars) {
if (isCall) {
Say("Procedure %s associated with result of reference to function '%s' that is an incompatible procedure pointer"_err_en_US,
description_, rhsName);
@ -234,7 +233,7 @@ void CheckPointerAssignment(parser::ContextualMessages &messages,
auto proc{characteristics::Procedure::Characterize(lhs, intrinsics)};
std::string description{"pointer '"s + lhs.name().ToString() + '\''};
PointerAssignmentChecker{&lhs, lhs.name(), description,
type ? &*type : nullptr, messages, intrinsics, proc,
type ? &*type : nullptr, messages, intrinsics, proc ? &*proc : nullptr,
lhs.attrs().test(semantics::Attr::CONTIGUOUS)}
.Check(rhs);
}
@ -244,9 +243,8 @@ void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, parser::CharBlock source,
const std::string &description, const characteristics::DummyDataObject &lhs,
const evaluate::Expr<evaluate::SomeType> &rhs) {
std::optional<characteristics::Procedure> proc;
PointerAssignmentChecker{nullptr, source, description, &lhs.type, messages,
intrinsics, proc,
intrinsics, nullptr /* proc */,
lhs.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}
.Check(rhs);
}
@ -275,7 +273,7 @@ struct ForallContext {
const auto iter{activeNames.find(name)};
if (iter != activeNames.cend()) {
return {integerKind};
} else if (outer != nullptr) {
} else if (outer) {
return outer->GetActiveIntKind(name);
} else {
return std::nullopt;
@ -354,7 +352,7 @@ private:
};
void AssignmentContext::Analyze(const parser::AssignmentStmt &) {
if (forall_ != nullptr) {
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
}
@ -364,7 +362,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &) {
void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &) {
CHECK(!where_);
if (forall_ != nullptr) {
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
}
@ -435,7 +433,7 @@ void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
void AssignmentContext::Analyze(
const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
CHECK(where_ != nullptr);
CHECK(where_);
const auto &elsewhereStmt{
std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
context_.set_location(elsewhereStmt.source);
@ -454,7 +452,7 @@ void AssignmentContext::Analyze(
std::move(where_->cumulativeMaskExpr), std::move(copyMask));
where_->thisMaskExpr = evaluate::BinaryLogicalOperation(
evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask));
if (where_->outer != nullptr &&
if (where_->outer &&
!evaluate::AreConformable(
where_->outer->thisMaskExpr, where_->thisMaskExpr)) {
Say(elsewhereStmt.source,
@ -507,7 +505,7 @@ MaskExpr AssignmentContext::GetMask(
if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
auto *logical{
std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
CHECK(logical != nullptr);
CHECK(logical);
mask = evaluate::ConvertTo(mask, std::move(*logical));
}
return mask;

139
flang/lib/semantics/check-call.cc
View File

@ -184,15 +184,28 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
UltimateComponentIterator ultimates{derived};
if (actualIsCoindexed && dummy.intent != common::Intent::In &&
!dummyIsValue) {
if (auto iter{std::find_if(
ultimates.begin(), ultimates.end(), [](const Symbol &component) {
return IsAllocatable(component);
})}) { // 15.5.2.4(6)
evaluate::SayWithDeclaration(messages, &*iter,
"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
iter.BuildResultDesignatorName(), dummyName);
if (actualIsCoindexed) {
if (dummy.intent != common::Intent::In && !dummyIsValue) {
if (auto iter{std::find_if(ultimates.begin(), ultimates.end(),
[](const Symbol &component) {
return IsAllocatable(component);
})}) { // 15.5.2.4(6)
evaluate::SayWithDeclaration(messages, &*iter,
"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
iter.BuildResultDesignatorName(), dummyName);
}
}
if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
const Symbol &coarray{coarrayRef->GetLastSymbol()};
if (const DeclTypeSpec * type{coarray.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
evaluate::SayWithDeclaration(messages, &coarray,
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
coarray.name(), ptr->name(), dummyName);
}
}
}
}
}
if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
@ -210,7 +223,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Rank and shape checks
const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
if (actualLastSymbol != nullptr) {
if (actualLastSymbol) {
actualLastSymbol = GetAssociationRoot(*actualLastSymbol);
}
const ObjectEntityDetails *actualLastObject{actualLastSymbol
@ -279,11 +292,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
} else if (dummyIsVolatile) {
reason = "VOLATILE";
}
if (reason != nullptr && scope != nullptr) {
if (reason && scope) {
bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21)
std::unique_ptr<parser::Message> why{
WhyNotModifiable(messages.at(), actual, *scope, vectorSubscriptIsOk)};
if (why.get() != nullptr) {
if (why.get()) {
if (auto *msg{messages.Say(
"Actual argument associated with %s %s must be definable"_err_en_US,
reason, dummyName)}) {
@ -437,6 +450,102 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
static void CheckProcedureArg(evaluate::ActualArgument &arg,
const characteristics::DummyProcedure &proc, const std::string &dummyName,
evaluate::FoldingContext &context) {
parser::ContextualMessages &messages{context.messages()};
const characteristics::Procedure &interface{proc.procedure.value()};
if (const auto *expr{arg.UnwrapExpr()}) {
bool dummyIsPointer{
proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
const auto *argProcDesignator{
std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
const auto *argProcSymbol{
argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
if (auto argChars{characteristics::DummyArgument::FromActual(
"actual argument", *expr, context)}) {
if (auto *argProc{
std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
characteristics::Procedure &argInterface{argProc->procedure.value()};
argInterface.attrs.reset(characteristics::Procedure::Attr::NullPointer);
if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
// It's ok to pass ELEMENTAL unrestricted intrinsic functions.
argInterface.attrs.reset(characteristics::Procedure::Attr::Elemental);
} else if (argInterface.attrs.test(
characteristics::Procedure::Attr::Elemental)) {
if (argProcSymbol) { // C1533
evaluate::SayWithDeclaration(messages, argProcSymbol,
"Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
argProcSymbol->name());
return; // avoid piling on with checks below
} else {
argInterface.attrs.reset(
characteristics::Procedure::Attr::NullPointer);
}
}
if (!interface.IsPure()) {
// 15.5.2.9(1): if dummy is not PURE, actual need not be.
argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
}
if (interface.HasExplicitInterface()) {
if (interface != argInterface) {
messages.Say(
"Actual argument procedure has interface incompatible with %s"_err_en_US,
dummyName);
}
} else { // 15.5.2.9(2,3)
if (interface.IsSubroutine() && argInterface.IsFunction()) {
messages.Say(
"Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
dummyName);
} else if (interface.IsFunction()) {
if (argInterface.IsFunction()) {
if (interface.functionResult != argInterface.functionResult) {
messages.Say(
"Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
dummyName);
}
} else if (argInterface.IsSubroutine()) {
messages.Say(
"Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
dummyName);
}
}
}
} else {
messages.Say(
"Actual argument associated with procedure %s is not a procedure"_err_en_US,
dummyName);
}
} else if (!(dummyIsPointer && IsNullPointer(*expr))) {
messages.Say(
"Actual argument associated with procedure %s is not a procedure"_err_en_US,
dummyName);
}
if (interface.HasExplicitInterface()) {
if (dummyIsPointer) {
// 15.5.2.9(5) -- dummy procedure POINTER
// Interface compatibility has already been checked above by comparison.
if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
messages.Say(
"Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
dummyName);
}
} else { // 15.5.2.9(4) -- dummy procedure is not POINTER
if (!argProcDesignator) {
messages.Say(
"Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US,
dummyName);
}
}
}
} else {
messages.Say(
"Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
dummyName);
}
}
static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
const characteristics::DummyArgument &dummy,
const characteristics::Procedure &proc, evaluate::FoldingContext &context,
@ -475,8 +584,10 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
"Actual argument is not an expression or variable"_err_en_US);
}
},
[](const auto &) {
// TODO check actual procedure compatibility
[&](const characteristics::DummyProcedure &proc) {
CheckProcedureArg(arg, proc, dummyName, context);
},
[&](const characteristics::AlternateReturn &) {
// TODO check alternate return
},
},

16
flang/lib/semantics/check-declarations.cc
View File

@ -172,6 +172,22 @@ void CheckHelper::Check(const Symbol &symbol) {
"An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
}
}
} else if (auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
if (proc->isDummy()) {
const Symbol *interface{proc->interface().symbol()};
if (!symbol.attrs().test(Attr::INTRINSIC) &&
(symbol.attrs().test(Attr::ELEMENTAL) ||
(interface && !interface->attrs().test(Attr::INTRINSIC) &&
interface->attrs().test(Attr::ELEMENTAL)))) {
// There's no explicit constraint or "shall" that we can find in the
// standard for this check, but it seems to be implied in multiple
// sites, and ELEMENTAL non-intrinsic actual arguments *are*
// explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy"
// because it is explicitly legal to *pass* the specific intrinsic
// function SIN as an actual argument.
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
}
}
}
if (symbol.attrs().test(Attr::VALUE)) {
CheckValue(symbol, derived);

32
flang/lib/semantics/expression.cc
View File

@ -202,7 +202,16 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
} else {
CHECK(std::holds_alternative<SymbolRef>(ref.u));
return Expr<SomeType>{ProcedureDesignator{symbol}};
if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
if (auto interface{
context_.intrinsics().IsUnrestrictedSpecificIntrinsicFunction(
symbol.name().ToString())}) {
return Expr<SomeType>{ProcedureDesignator{SpecificIntrinsic{
symbol.name().ToString(), std::move(*interface)}}};
}
} else {
return Expr<SomeType>{ProcedureDesignator{symbol}};
}
}
} else if (auto dyType{DynamicType::From(symbol)}) {
return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
@ -2520,27 +2529,6 @@ std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
} else if (MaybeExpr argExpr{context_.Analyze(expr)}) {
Expr<SomeType> x{Fold(context_.GetFoldingContext(), std::move(*argExpr))};
if (const auto *proc{std::get_if<ProcedureDesignator>(&x.u)}) {
if (!std::holds_alternative<SpecificIntrinsic>(proc->u) &&
proc->IsElemental()) { // C1533
context_.Say(expr.source,
"Non-intrinsic ELEMENTAL procedure cannot be passed as argument"_err_en_US);
}
}
if (auto coarrayRef{ExtractCoarrayRef(x)}) {
const Symbol &coarray{coarrayRef->GetLastSymbol()};
if (const semantics::DeclTypeSpec * type{coarray.GetType()}) {
if (const semantics::DerivedTypeSpec * derived{type->AsDerived()}) {
if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
AttachDeclaration(
context_.Say(expr.source,
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be passed as argument"_err_en_US,
coarray.name(), ptr->name()),
&*ptr);
}
}
}
}
return ActualArgument{std::move(x)};
} else {
return std::nullopt;

45
flang/lib/semantics/resolve-names.cc
View File

@ -1340,6 +1340,7 @@ public:
ResolveName(*parser::Unwrap<parser::Name>(x.name));
}
void Post(const parser::ProcComponentRef &);
bool Pre(const parser::ActualArg &);
bool Pre(const parser::FunctionReference &);
bool Pre(const parser::CallStmt &);
bool Pre(const parser::ImportStmt &);
@ -4301,12 +4302,7 @@ Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
}
bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) {
if (Symbol * symbol{FindSymbol(name)}) {
Resolve(name, *symbol);
return true;
} else {
return HandleUnrestrictedSpecificIntrinsicFunction(name);
}
return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name);
}
// Check if this derived type can be in a COMMON block.
@ -4342,10 +4338,8 @@ void DeclarationVisitor::CheckCommonBlockDerivedType(
bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
const parser::Name &name) {
if (context()
.intrinsics()
.IsUnrestrictedSpecificIntrinsicFunction(name.source.ToString())
.has_value()) {
if (context().intrinsics().IsUnrestrictedSpecificIntrinsicFunction(
name.source.ToString())) {
// Unrestricted specific intrinsic function names (e.g., "cos")
// are acceptable as procedure interfaces.
Symbol &symbol{MakeSymbol(InclusiveScope(), name.source,
@ -4794,9 +4788,7 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
bool ConstructVisitor::Pre(const parser::DataStmtObject &x) {
std::visit(
common::visitors{
[&](const common::Indirection<parser::Variable> &y) {
Walk(y.value());
},
[&](const Indirection<parser::Variable> &y) { Walk(y.value()); },
[&](const parser::DataImpliedDo &y) {
PushScope(Scope::Kind::ImpliedDos, nullptr);
Walk(y);
@ -5106,6 +5098,23 @@ const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec(
// ResolveNamesVisitor implementation
// Ensures that bare undeclared intrinsic procedure names passed as actual
// arguments get recognized as being intrinsics.
bool ResolveNamesVisitor::Pre(const parser::ActualArg &arg) {
if (const auto *expr{std::get_if<Indirection<parser::Expr>>(&arg.u)}) {
if (const auto *designator{
std::get_if<Indirection<parser::Designator>>(&expr->value().u)}) {
if (const auto *dataRef{
std::get_if<parser::DataRef>(&designator->value().u)}) {
if (const auto *name{std::get_if<parser::Name>(&dataRef->u)}) {
NameIsKnownOrIntrinsic(*name);
}
}
}
}
return true;
}
bool ResolveNamesVisitor::Pre(const parser::FunctionReference &x) {
HandleCall(Symbol::Flag::Function, x.v);
return false;
@ -5178,11 +5187,11 @@ const parser::Name *DeclarationVisitor::ResolveDataRef(
[=](const Indirection<parser::StructureComponent> &y) {
return ResolveStructureComponent(y.value());
},
[&](const common::Indirection<parser::ArrayElement> &y) {
[&](const Indirection<parser::ArrayElement> &y) {
Walk(y.value().subscripts);
return ResolveDataRef(y.value().base);
},
[&](const common::Indirection<parser::CoindexedNamedObject> &y) {
[&](const Indirection<parser::CoindexedNamedObject> &y) {
Walk(y.value().imageSelector);
return ResolveDataRef(y.value().base);
},
@ -5194,10 +5203,10 @@ const parser::Name *DeclarationVisitor::ResolveVariable(
const parser::Variable &x) {
return std::visit(
common::visitors{
[&](const common::Indirection<parser::Designator> &y) {
[&](const Indirection<parser::Designator> &y) {
return ResolveDesignator(y.value());
},
[&](const common::Indirection<parser::FunctionReference> &y) {
[&](const Indirection<parser::FunctionReference> &y) {
const auto &proc{
std::get<parser::ProcedureDesignator>(y.value().v.t)};
return std::visit(
@ -5398,7 +5407,7 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
details->set_init(std::move(*expr));
}
},
[&](const std::list<common::Indirection<parser::DataStmtValue>> &) {
[&](const std::list<Indirection<parser::DataStmtValue>> &) {
if (inComponentDecl) {
Say(name,
"Component '%s' initialized with DATA statement values"_err_en_US);

1
flang/test/semantics/CMakeLists.txt
View File

@ -182,6 +182,7 @@ set(ERROR_TESTS
call06.f90
call07.f90
call08.f90
call09.f90
call13.f90
call14.f90
misc-declarations.f90

26
flang/test/semantics/call02.f90
View File

@ -16,18 +16,20 @@
subroutine s01(elem, subr)
interface
! Merely declaring an elemental dummy procedure is not an error;
! if the actual argument were an elemental unrestricted specific
! intrinsic function, that's okay.
elemental real function elem(x)
real, value :: x
real, intent(in), value :: x
end function
subroutine subr(elem)
procedure(sin) :: elem
subroutine subr(dummy)
procedure(sin) :: dummy
end subroutine
!ERROR: A dummy procedure may not be ELEMENTAL
subroutine badsubr(dummy)
import :: elem
procedure(elem) :: dummy
end subroutine
end interface
call subr(cos) ! not an error
!ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
call subr(elem) ! C1533
end subroutine
@ -47,13 +49,13 @@ module m01
end function
subroutine test
call callme(cos) ! not an error
!ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem01' may not be passed as an actual argument
call callme(elem01) ! C1533
!ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem02' may not be passed as an actual argument
call callme(elem02) ! C1533
!ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem03' may not be passed as an actual argument
call callme(elem03) ! C1533
!ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem04' may not be passed as an actual argument
call callme(elem04) ! C1533
contains
elemental real function elem04(x)
@ -72,7 +74,7 @@ module m02
type(t), intent(in) :: x
end subroutine
subroutine test
!ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be passed as argument
!ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be associated with dummy argument 'x='
call callee(coarray[1]) ! C1537
end subroutine
end module

151
flang/test/semantics/call09.f90
View File

@ -12,41 +12,166 @@
! See the License for the specific language governing permissions and
! limitations under the License.
! Test 15.5.2.9(5) dummy procedure POINTER requirements
! Test 15.5.2.9(2,3,5) dummy procedure requirements
module m
contains
integer function intfunc(x)
integer, intent(in) :: x
intfunc = x
end function
real function realfunc(x)
real, intent(in) :: x
realfunc = x
end function
subroutine s01(p)
procedure(sin), pointer, intent(in) :: p
procedure(realfunc), pointer, intent(in) :: p
end subroutine
subroutine s02(p)
procedure(sin), pointer :: p
procedure(realfunc), pointer :: p
end subroutine
subroutine selemental1(p)
procedure(cos) :: p ! ok
end subroutine
real elemental function elemfunc(x)
real, intent(in) :: x
elemfunc = x
end function
!ERROR: A dummy procedure may not be ELEMENTAL
subroutine selemental2(p)
procedure(elemfunc) :: p
end subroutine
function procptr()
procedure(sin), pointer :: procptr
procptr => cos
procedure(realfunc), pointer :: procptr
procptr => realfunc
end function
function intprocptr()
procedure(intfunc), pointer :: intprocptr
procptr => intfunc
end function
subroutine test
procedure(tan), pointer :: p
p => tan
subroutine test1 ! 15.5.2.9(5)
procedure(realfunc), pointer :: p
procedure(intfunc), pointer :: ip
p => realfunc
ip => intfunc
call s01(realfunc) ! ok
!ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
call s01(intfunc)
call s01(p) ! ok
call s01(procptr()) ! ok
!ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
call s01(intprocptr())
call s01(null()) ! ok
call s01(null(p)) ! ok
!ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
call s01(null(ip))
call s01(sin) ! ok
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(realfunc)
call s02(p) ! ok
!ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN)
!ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
call s02(ip)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(procptr())
!ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(null())
!ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(null(p))
!ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(sin)
end subroutine
subroutine callsub(s)
call s
end subroutine
subroutine takesrealfunc1(f)
external f
real f
end subroutine
subroutine takesrealfunc2(f)
x = f(1)
end subroutine
subroutine forwardproc(p)
implicit none
external :: p ! function or subroutine not known
call foo(p)
end subroutine
subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3)
external :: unknown, ds, drf, dif
real :: drf
integer :: dif
procedure(callsub), pointer :: ps
procedure(realfunc), pointer :: prf
procedure(intfunc), pointer :: pif
call ds ! now we know that's it's a subroutine
call callsub(callsub) ! ok apart from infinite recursion
call callsub(unknown) ! ok
call callsub(ds) ! ok
call callsub(ps) ! ok
call takesrealfunc1(realfunc) ! ok
call takesrealfunc1(unknown) ! ok
call takesrealfunc1(drf) ! ok
call takesrealfunc1(prf) ! ok
call takesrealfunc2(realfunc) ! ok
call takesrealfunc2(unknown) ! ok
call takesrealfunc2(drf) ! ok
call takesrealfunc2(prf) ! ok
call forwardproc(callsub) ! ok
call forwardproc(realfunc) ! ok
call forwardproc(intfunc) ! ok
call forwardproc(unknown) ! ok
call forwardproc(ds) ! ok
call forwardproc(drf) ! ok
call forwardproc(dif) ! ok
call forwardproc(ps) ! ok
call forwardproc(prf) ! ok
call forwardproc(pif) ! ok
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(realfunc)
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(intfunc)
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(drf)
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(dif)
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(prf)
!ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
call callsub(pif)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc1(callsub)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc1(ds)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc1(ps)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc1(intfunc)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc1(dif)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc1(pif)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc1(intfunc)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc2(callsub)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc2(ds)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc2(ps)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc2(intfunc)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc2(dif)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc2(pif)
!ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
call takesrealfunc2(intfunc)
end subroutine
end module

7
flang/test/semantics/expr-errors02.f90
View File

@ -22,12 +22,13 @@ module m
interface
integer function foo()
end function
pure integer function hasProcArg(p)
procedure(cos) :: p
end function
real function realfunc(x)
real, intent(in) :: x
end function
pure integer function hasProcArg(p)
import realfunc
procedure(realfunc) :: p
end function
end interface
integer :: coarray[*]
contains