[flang-commits] [flang] 62d874f - [flang] Refine semantic checks for procedure pointer assignment
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Jul 13 14:57:03 PDT 2022
Author: Peter Klausler
Date: 2022-07-13T14:56:50-07:00
New Revision: 62d874f203078896b4f059f7aa4f106e8cbab4da
URL: https://github.com/llvm/llvm-project/commit/62d874f203078896b4f059f7aa4f106e8cbab4da
DIFF: https://github.com/llvm/llvm-project/commit/62d874f203078896b4f059f7aa4f106e8cbab4da.diff
LOG: [flang] Refine semantic checks for procedure pointer assignment
Some procedure pointers and EXTERNAL procedures have neither
explicit interfaces nor result types; these procedures are obviously
not known to be functions, but they could be, so semantics must not
assume that they are necessarily subroutines. Refine the procedure
pointer / dummy procedure compatibility check to handle these more
ambiguous cases and not elicit inappropriate error messages.
Differential Revision: https://reviews.llvm.org/D129674
Added:
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/test/Semantics/assign03.f90
flang/test/Semantics/associated.f90
flang/test/Semantics/call09.f90
flang/test/Semantics/call20.f90
flang/test/Semantics/null01.f90
flang/test/Semantics/resolve46.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 3bd11dae57252..0b8f7c2cecbd5 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -190,7 +190,8 @@ struct DummyDataObject {
bool operator!=(const DummyDataObject &that) const {
return !(*this == that);
}
- bool IsCompatibleWith(const DummyDataObject &) const;
+ bool IsCompatibleWith(
+ const DummyDataObject &, std::string *whyNot = nullptr) const;
static std::optional<DummyDataObject> Characterize(
const semantics::Symbol &, FoldingContext &);
bool CanBePassedViaImplicitInterface() const;
@@ -209,7 +210,8 @@ struct DummyProcedure {
explicit DummyProcedure(Procedure &&);
bool operator==(const DummyProcedure &) const;
bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
- bool IsCompatibleWith(const DummyProcedure &) const;
+ bool IsCompatibleWith(
+ const DummyProcedure &, std::string *whyNot = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
CopyableIndirection<Procedure> procedure;
@@ -243,7 +245,8 @@ struct DummyArgument {
void SetIntent(common::Intent);
bool CanBePassedViaImplicitInterface() const;
bool IsTypelessIntrinsicDummy() const;
- bool IsCompatibleWith(const DummyArgument &) const;
+ bool IsCompatibleWith(
+ const DummyArgument &, std::string *whyNot = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
// name and pass are not characteristics and so do not participate in
@@ -284,7 +287,8 @@ struct FunctionResult {
}
void SetType(DynamicType t) { std::get<TypeAndShape>(u).set_type(t); }
bool CanBeReturnedViaImplicitInterface() const;
- bool IsCompatibleWith(const FunctionResult &) const;
+ bool IsCompatibleWith(
+ const FunctionResult &, std::string *whyNot = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
@@ -329,7 +333,7 @@ struct Procedure {
int FindPassIndex(std::optional<parser::CharBlock>) const;
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
- bool IsCompatibleWith(const Procedure &) const;
+ bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index f3aaf59fd136b..93dd98c273b4c 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1025,7 +1025,8 @@ template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
// message that needs to be augmented by the names of the left and right sides
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
- const characteristics::Procedure *rhsProcedure);
+ const characteristics::Procedure *rhsProcedure,
+ std::string &whyNotCompatible);
// Scalar constant expansion
class ScalarConstantExpander {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index ea592e5b6a8f8..fa7190420c8d4 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -257,11 +257,45 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
coshape == that.coshape;
}
-bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual) const {
- return type.shape() == actual.type.shape() &&
- type.type().IsTkCompatibleWith(actual.type.type()) &&
- attrs == actual.attrs && intent == actual.intent &&
- coshape == actual.coshape;
+static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
+ // TODO: Validate more than just compatible ranks
+ return GetRank(x) == GetRank(y);
+}
+
+bool DummyDataObject::IsCompatibleWith(
+ const DummyDataObject &actual, std::string *whyNot) const {
+ if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object shapes";
+ }
+ return false;
+ }
+ if (!type.type().IsTkCompatibleWith(actual.type.type())) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object types: "s +
+ type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
+ }
+ return false;
+ }
+ if (attrs != actual.attrs) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object attributes";
+ }
+ return false;
+ }
+ if (intent != actual.intent) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object intents";
+ }
+ return false;
+ }
+ if (coshape != actual.coshape) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy data object coshapes";
+ }
+ return false;
+ }
+ return true;
}
static common::Intent GetIntent(const semantics::Attrs &attrs) {
@@ -346,9 +380,27 @@ bool DummyProcedure::operator==(const DummyProcedure &that) const {
procedure.value() == that.procedure.value();
}
-bool DummyProcedure::IsCompatibleWith(const DummyProcedure &actual) const {
- return attrs == actual.attrs && intent == actual.intent &&
- procedure.value().IsCompatibleWith(actual.procedure.value());
+bool DummyProcedure::IsCompatibleWith(
+ const DummyProcedure &actual, std::string *whyNot) const {
+ if (attrs != actual.attrs) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy procedure attributes";
+ }
+ return false;
+ }
+ if (intent != actual.intent) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy procedure intents";
+ }
+ return false;
+ }
+ if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
+ }
+ return false;
+ }
+ return true;
}
static std::string GetSeenProcs(
@@ -558,17 +610,32 @@ bool DummyArgument::operator==(const DummyArgument &that) const {
return u == that.u; // name and passed-object usage are not characteristics
}
-bool DummyArgument::IsCompatibleWith(const DummyArgument &actual) const {
+bool DummyArgument::IsCompatibleWith(
+ const DummyArgument &actual, std::string *whyNot) const {
if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
- const auto *actualData{std::get_if<DummyDataObject>(&actual.u)};
- return actualData && ifaceData->IsCompatibleWith(*actualData);
+ if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
+ return ifaceData->IsCompatibleWith(*actualData, whyNot);
+ }
+ if (whyNot) {
+ *whyNot = "one dummy argument is an object, the other is not";
+ }
} else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
- const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)};
- return actualProc && ifaceProc->IsCompatibleWith(*actualProc);
+ if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) {
+ return ifaceProc->IsCompatibleWith(*actualProc, whyNot);
+ }
+ if (whyNot) {
+ *whyNot = "one dummy argument is a procedure, the other is not";
+ }
} else {
- return std::holds_alternative<AlternateReturn>(u) &&
- std::holds_alternative<AlternateReturn>(actual.u);
+ CHECK(std::holds_alternative<AlternateReturn>(u));
+ if (std::holds_alternative<AlternateReturn>(actual.u)) {
+ return true;
+ }
+ if (whyNot) {
+ *whyNot = "one dummy argument is an alternate return, the other is not";
+ }
}
+ return false;
}
static std::optional<DummyArgument> CharacterizeDummyArgument(
@@ -789,34 +856,62 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
}
}
-bool FunctionResult::IsCompatibleWith(const FunctionResult &actual) const {
+bool FunctionResult::IsCompatibleWith(
+ const FunctionResult &actual, std::string *whyNot) const {
Attrs actualAttrs{actual.attrs};
- actualAttrs.reset(Attr::Contiguous);
+ if (!attrs.test(Attr::Contiguous)) {
+ actualAttrs.reset(Attr::Contiguous);
+ }
if (attrs != actualAttrs) {
- return false;
+ if (whyNot) {
+ *whyNot = "function results have incompatible attributes";
+ }
} else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
- return false;
+ if (whyNot) {
+ *whyNot = "function results have distinct ranks";
+ }
} else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
ifaceTypeShape->shape() != actualTypeShape->shape()) {
- return false;
+ if (whyNot) {
+ *whyNot = "function results have distinct extents";
+ }
+ } else if (!ifaceTypeShape->type().IsTkCompatibleWith(
+ actualTypeShape->type())) {
+ if (whyNot) {
+ *whyNot = "function results have incompatible types: "s +
+ ifaceTypeShape->type().AsFortran() + " vs "s +
+ actualTypeShape->type().AsFortran();
+ }
} else {
- return ifaceTypeShape->type().IsTkCompatibleWith(
- actualTypeShape->type());
+ return true;
}
} else {
- return false;
+ if (whyNot) {
+ *whyNot = "function result type and shape are not known";
+ }
}
} else {
const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
+ CHECK(ifaceProc != nullptr);
if (const auto *actualProc{
std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
- return ifaceProc->value().IsCompatibleWith(actualProc->value());
+ if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) {
+ return true;
+ }
+ if (whyNot) {
+ *whyNot =
+ "function results are incompatible procedure pointers: "s + *whyNot;
+ }
} else {
- return false;
+ if (whyNot) {
+ *whyNot =
+ "one function result is a procedure pointer, the other is not";
+ }
}
}
+ return false;
}
llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
@@ -843,29 +938,47 @@ bool Procedure::operator==(const Procedure &that) const {
dummyArguments == that.dummyArguments;
}
-bool Procedure::IsCompatibleWith(const Procedure &actual) const {
+bool Procedure::IsCompatibleWith(
+ const Procedure &actual, std::string *whyNot) const {
// 15.5.2.9(1): if dummy is not pure, actual need not be.
+ // Ditto with elemental.
Attrs actualAttrs{actual.attrs};
if (!attrs.test(Attr::Pure)) {
actualAttrs.reset(Attr::Pure);
}
+ if (!attrs.test(Attr::Elemental)) {
+ actualAttrs.reset(Attr::Elemental);
+ }
if (attrs != actualAttrs) {
- return false;
- } else if (IsFunction() != actual.IsFunction()) {
- return false;
- } else if (IsFunction() &&
- !functionResult->IsCompatibleWith(*actual.functionResult)) {
- return false;
+ if (whyNot) {
+ *whyNot = "incompatible procedure attributes";
+ }
+ } else if ((IsFunction() && actual.IsSubroutine()) ||
+ (IsSubroutine() && actual.IsFunction())) {
+ if (whyNot) {
+ *whyNot =
+ "incompatible procedures: one is a function, the other a subroutine";
+ }
+ } else if (functionResult && actual.functionResult &&
+ !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
} else if (dummyArguments.size() != actual.dummyArguments.size()) {
- return false;
+ if (whyNot) {
+ *whyNot = "distinct numbers of dummy arguments";
+ }
} else {
for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
- if (!dummyArguments[j].IsCompatibleWith(actual.dummyArguments[j])) {
+ if (!dummyArguments[j].IsCompatibleWith(
+ actual.dummyArguments[j], whyNot)) {
+ if (whyNot) {
+ *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
+ ": "s + *whyNot;
+ }
return false;
}
}
return true;
}
+ return false;
}
int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
@@ -954,8 +1067,10 @@ llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
attrs.Dump(o, EnumToString);
if (functionResult) {
functionResult->Dump(o << "TYPE(") << ") FUNCTION";
- } else {
+ } else if (attrs.test(Attr::Subroutine)) {
o << "SUBROUTINE";
+ } else {
+ o << "EXTERNAL";
}
char sep{'('};
for (const auto &dummy : dummyArguments) {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 70b87baf6114d..d9a7084c52098 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2258,14 +2258,15 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
if (pointerProc) {
if (targetProc) {
// procedure pointer and procedure target
+ std::string whyNot;
if (std::optional<parser::MessageFixedText> msg{
CheckProcCompatibility(
- isCall, pointerProc, &*targetProc)}) {
+ isCall, pointerProc, &*targetProc, whyNot)}) {
AttachDeclaration(
context.messages().Say(std::move(*msg),
"pointer '" + pointerSymbol->name().ToString() +
"'",
- targetName),
+ targetName, whyNot),
*pointerSymbol);
}
} else {
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index b04bf21164ad0..258795118c0fd 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -939,26 +939,14 @@ std::optional<std::string> FindImpureCall(
return FindImpureCallHelper{context}(proc);
}
-// Compare procedure characteristics for equality except that rhs may be
-// Pure or Elemental when lhs is not.
-static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
- const characteristics::Procedure &rhs) {
- using Attr = characteristics::Procedure::Attr;
- auto lhsAttrs{lhs.attrs};
- lhsAttrs.set(
- Attr::Pure, lhs.attrs.test(Attr::Pure) || rhs.attrs.test(Attr::Pure));
- lhsAttrs.set(Attr::Elemental,
- lhs.attrs.test(Attr::Elemental) || rhs.attrs.test(Attr::Elemental));
- return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
- lhs.dummyArguments == rhs.dummyArguments;
-}
-
// Common handling for procedure pointer compatibility of left- and right-hand
// sides. Returns nullopt if they're compatible. Otherwise, it returns a
// message that needs to be augmented by the names of the left and right sides
+// and the content of the "whyNotCompatible" string.
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
- const characteristics::Procedure *rhsProcedure) {
+ const characteristics::Procedure *rhsProcedure,
+ std::string &whyNotCompatible) {
std::optional<parser::MessageFixedText> msg;
if (!lhsProcedure) {
msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -966,18 +954,18 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
} else if (!rhsProcedure) {
msg = "In assignment to procedure %s, the characteristics of the target"
" procedure '%s' could not be determined"_err_en_US;
- } else if (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
+ } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible)) {
// OK
} else if (isCall) {
msg = "Procedure %s associated with result of reference to function '%s'"
- " that is an incompatible procedure pointer"_err_en_US;
+ " that is an incompatible procedure pointer: %s"_err_en_US;
} else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
msg = "PURE procedure %s may not be associated with non-PURE"
" procedure designator '%s'"_err_en_US;
- } else if (lhsProcedure->IsFunction() && !rhsProcedure->IsFunction()) {
+ } else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
msg = "Function %s may not be associated with subroutine"
" designator '%s'"_err_en_US;
- } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
+ } else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
msg = "Subroutine %s may not be associated with function"
" designator '%s'"_err_en_US;
} else if (lhsProcedure->HasExplicitInterface() &&
@@ -1002,7 +990,7 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
}
} else {
msg = "Procedure %s associated with incompatible procedure"
- " designator '%s'"_err_en_US;
+ " designator '%s': %s"_err_en_US;
}
return msg;
}
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 10d178b312c72..cbf48aef042c8 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -602,12 +602,13 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
}
}
if (interface.HasExplicitInterface()) {
- if (!interface.IsCompatibleWith(argInterface)) {
+ std::string whyNot;
+ if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
// 15.5.2.9(1): Explicit interfaces must match
if (argInterface.HasExplicitInterface()) {
messages.Say(
- "Actual procedure argument has interface incompatible with %s"_err_en_US,
- dummyName);
+ "Actual procedure argument has interface incompatible with %s: %s"_err_en_US,
+ dummyName, whyNot);
return;
} else if (proc.IsPure()) {
messages.Say(
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index d55fa16001335..cfb5159d92ebf 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -257,9 +257,10 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
// Common handling for procedure pointer right-hand sides
bool PointerAssignmentChecker::Check(
parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
- if (std::optional<MessageFixedText> msg{
- evaluate::CheckProcCompatibility(isCall, procedure_, rhsProcedure)}) {
- Say(std::move(*msg), description_, rhsName);
+ std::string whyNot;
+ if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
+ isCall, procedure_, rhsProcedure, whyNot)}) {
+ Say(std::move(*msg), description_, rhsName, whyNot);
return false;
}
return true;
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index b7431893d9dbc..cedcb775ca4e3 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -93,18 +93,18 @@ subroutine s5
sp_pure => s_pure1 ! OK, same characteristics
sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
- !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2'
+ !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2': incompatible dummy argument #1: incompatible dummy data object intents
p_impure => f_impure2
- !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2'
+ !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
p_pure => f_pure2
- !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2'
+ !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible dummy argument #1: incompatible dummy data object attributes
p_impure => f_elemental2
- !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2'
+ !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes
sp_impure => s_impure2
- !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2'
+ !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2': incompatible dummy argument #1: incompatible dummy data object intents
sp_impure => s_pure2
- !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2'
+ !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': distinct numbers of dummy arguments
sp_pure => s_elemental2
!ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
@@ -188,9 +188,9 @@ subroutine s7
procedure(real), pointer :: p_f
p_f => f_external
p_s => s_external
- !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
+ !Ok: p_s has no interface
p_s => f_external
- !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
+ !Ok: s_external has no interface
p_f => s_external
end
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index 34583c477e16f..0bca7edf8e2fb 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -135,9 +135,9 @@ subroutine test()
intprocPointer1 => intVar
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
lVar = associated(intprocPointer1, intVar)
- !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+ !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
intProcPointer1 => elementalProc
- !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+ !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible dummy argument #1: incompatible dummy data object attributes
lvar = associated(intProcPointer1, elementalProc)
!ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
lvar = associated (intPointerVar1, intFunc)
@@ -147,17 +147,17 @@ subroutine test()
intProcPointer1 => targetIntVar1
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
lvar = associated (intProcPointer1, targetIntVar1)
- !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+ !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
intProcPointer1 => null(mold=realProcPointer1)
- !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer
+ !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have incompatible types: INTEGER(4) vs REAL(4)
lvar = associated(intProcPointer1, null(mold=realProcPointer1))
!ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
pureFuncPointer => intProc
!ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
lvar = associated(pureFuncPointer, intProc)
- !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+ !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
realProcPointer1 => intProc
- !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+ !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
lvar = associated(realProcPointer1, intProc)
subProcPointer => externalProc ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
lvar = associated(subProcPointer, externalProc) ! OK to associate a procedure pointer with an explicit interface to a procedure with an implicit interface
diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index 23591687189ef..f3319898e6b84 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -60,15 +60,15 @@ subroutine test1 ! 15.5.2.9(5)
p => realfunc
ip => intfunc
call s01(realfunc) ! ok
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
call s01(intfunc)
call s01(p) ! ok
call s01(procptr()) ! ok
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
call s01(intprocptr())
call s01(null()) ! ok
call s01(null(p)) ! ok
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
call s01(null(ip))
call s01(sin) ! ok
!ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
@@ -78,7 +78,7 @@ subroutine test1 ! 15.5.2.9(5)
!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: Actual procedure argument has interface incompatible with dummy argument 'p='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
call s02(ip)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(procptr())
diff --git a/flang/test/Semantics/call20.f90 b/flang/test/Semantics/call20.f90
index 91ce2bfccc7f6..ee33a7e90da9c 100644
--- a/flang/test/Semantics/call20.f90
+++ b/flang/test/Semantics/call20.f90
@@ -30,9 +30,9 @@ function f(x)
! OK
call foo2(dabs)
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have incompatible types: REAL(4) vs REAL(8)
call foo(dabs)
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f='
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have incompatible types: REAL(8) vs REAL(4)
call foo2(abs)
end
diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90
index 8c89a0b9cbc15..be98d27bd91e1 100644
--- a/flang/test/Semantics/null01.f90
+++ b/flang/test/Semantics/null01.f90
@@ -72,9 +72,9 @@ function f3()
dt1x = dt1(ip1=null(mold=rp1))
dt2x = dt2(pps0=null())
dt2x = dt2(pps0=null(mold=dt2x%pps0))
- !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer
+ !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
dt2x = dt2(pps0=null(mold=dt3x%pps1))
- !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+ !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
dt3x = dt3(pps1=null(mold=dt2x%pps0))
dt3x = dt3(pps1=null(mold=dt3x%pps1))
call canbenull(null(), null()) ! fine
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index 981008ae3ea4f..e50caaf8836ef 100644
--- a/flang/test/Semantics/resolve46.f90
+++ b/flang/test/Semantics/resolve46.f90
@@ -34,9 +34,9 @@ end function chrcmp
p => alog10 ! ditto, but already declared intrinsic
p => cos ! ditto, but also generic
p => tan ! a generic & an unrestricted specific, not already declared
- !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod'
+ !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod': function results have incompatible types: REAL(4) vs INTEGER(4)
p => mod
- !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index'
+ !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index': function results have incompatible types: REAL(4) vs INTEGER(4)
p => index
!ERROR: 'bessel_j0' is not an unrestricted specific intrinsic procedure
p => bessel_j0
More information about the flang-commits
mailing list