[flang-commits] [flang] c6b9df0 - [flang] Refine procedure compatibility checking
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Mar 2 09:32:01 PST 2023
Author: Peter Klausler
Date: 2023-03-02T09:22:06-08:00
New Revision: c6b9df0fbd7fc6f93e3bd7368cf966d55d802f4c
URL: https://github.com/llvm/llvm-project/commit/c6b9df0fbd7fc6f93e3bd7368cf966d55d802f4c
DIFF: https://github.com/llvm/llvm-project/commit/c6b9df0fbd7fc6f93e3bd7368cf966d55d802f4c.diff
LOG: [flang] Refine procedure compatibility checking
The test for compatible function results needs to be nearly strict
equality of their types, not the usual actual/dummy type compatibility
test used in other situations. The exceptional case is that assumed
length CHARACTER function results are compatible with explicit length
results of the same kind. In particular, a function returning a
polymorphic pointer is not compatible with a function returning a
monomorphic pointer even of the same declared type.
Differential Revision: https://reviews.llvm.org/D145094
Added:
Modified:
flang/include/flang/Evaluate/type.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/assign03.f90
flang/test/Semantics/associated.f90
flang/test/Semantics/call09.f90
flang/test/Semantics/call20.f90
flang/test/Semantics/call25.f90
flang/test/Semantics/resolve46.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index a37df69e6ee4..0338dcb1f145 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -467,6 +467,11 @@ std::optional<DynamicType> ComparisonType(
bool IsInteroperableIntrinsicType(const DynamicType &);
+// Determine whether two derived type specs are sufficiently identical
+// to be considered the "same" type even if declared separately.
+bool AreSameDerivedType(
+ const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y);
+
// For generating "[extern] template class", &c. boilerplate
#define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index cdd746d771aa..8c9002f3ca1d 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -925,10 +925,32 @@ bool FunctionResult::IsCompatibleWith(
if (whyNot) {
*whyNot = "function results have distinct constant extents";
}
- } else if (!ifaceTypeShape->type().IsTkLenCompatibleWith(
- actualTypeShape->type())) {
+ } else if (ifaceTypeShape->type() != actualTypeShape->type()) {
+ if (ifaceTypeShape->type().category() ==
+ actualTypeShape->type().category()) {
+ if (ifaceTypeShape->type().category() == TypeCategory::Character) {
+ if (ifaceTypeShape->type().kind() ==
+ actualTypeShape->type().kind()) {
+ auto ifaceLen{ifaceTypeShape->type().knownLength()};
+ auto actualLen{actualTypeShape->type().knownLength()};
+ if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) {
+ return true;
+ }
+ }
+ } else if (ifaceTypeShape->type().category() ==
+ TypeCategory::Derived) {
+ if (ifaceTypeShape->type().IsPolymorphic() ==
+ actualTypeShape->type().IsPolymorphic() &&
+ !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
+ !actualTypeShape->type().IsUnlimitedPolymorphic() &&
+ AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
+ actualTypeShape->type().GetDerivedTypeSpec())) {
+ return true;
+ }
+ }
+ }
if (whyNot) {
- *whyNot = "function results have incompatible types: "s +
+ *whyNot = "function results have distinct types: "s +
ifaceTypeShape->type().AsFortran() + " vs "s +
actualTypeShape->type().AsFortran();
}
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 7c9219e15f7f..f5d5d5b0efc3 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -245,8 +245,19 @@ using SetOfDerivedTypePairs =
std::set<std::pair<const semantics::DerivedTypeSpec *,
const semantics::DerivedTypeSpec *>>;
-static bool AreSameComponent(const semantics::Symbol &,
- const semantics::Symbol &, SetOfDerivedTypePairs &inProgress);
+static bool AreSameComponent(const semantics::Symbol &x,
+ const semantics::Symbol &y,
+ SetOfDerivedTypePairs & /* inProgress - not yet used */) {
+ if (x.attrs() != y.attrs()) {
+ return false;
+ }
+ if (x.attrs().test(semantics::Attr::PRIVATE)) {
+ return false;
+ }
+ // TODO: compare types, parameters, bounds, &c.
+ return x.has<semantics::ObjectEntityDetails>() ==
+ y.has<semantics::ObjectEntityDetails>();
+}
static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) {
@@ -293,18 +304,10 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
return yComponentName == yEnd;
}
-static bool AreSameComponent(const semantics::Symbol &x,
- const semantics::Symbol &y,
- SetOfDerivedTypePairs & /* inProgress - not yet used */) {
- if (x.attrs() != y.attrs()) {
- return false;
- }
- if (x.attrs().test(semantics::Attr::PRIVATE)) {
- return false;
- }
- // TODO: compare types, parameters, bounds, &c.
- return x.has<semantics::ObjectEntityDetails>() ==
- y.has<semantics::ObjectEntityDetails>();
+bool AreSameDerivedType(
+ const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
+ SetOfDerivedTypePairs inProgress;
+ return AreSameDerivedType(x, y, inProgress);
}
static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
@@ -312,8 +315,7 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
if (!x || !y) {
return false;
} else {
- SetOfDerivedTypePairs inProgress;
- if (AreSameDerivedType(*x, *y, inProgress)) {
+ if (AreSameDerivedType(*x, *y)) {
return true;
} else {
return isPolymorphic &&
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index b5d912b640fe..275673e6e5ea 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -702,11 +702,12 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
dummyName);
} else if (interface.IsFunction()) {
if (argInterface.IsFunction()) {
+ std::string whyNot;
if (!interface.functionResult->IsCompatibleWith(
- *argInterface.functionResult)) {
+ *argInterface.functionResult, &whyNot)) {
messages.Say(
- "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
- dummyName);
+ "Actual argument function associated with procedure %s is not compatible: %s"_err_en_US,
+ dummyName, whyNot);
}
} else if (argInterface.IsSubroutine()) {
messages.Say(
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index ccea6bb2f7b3..a80ef1e102b2 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -101,9 +101,9 @@ subroutine s5
!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: Function pointer 'p_pure' associated with incompatible function designator 'f_pure2': function results have incompatible types: INTEGER(4) vs REAL(4)
+ !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'f_pure2': function results have distinct types: INTEGER(4) vs REAL(4)
p_pure => f_pure2
- !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'ccos': function results have incompatible types: INTEGER(4) vs COMPLEX(4)
+ !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'ccos': function results have distinct types: INTEGER(4) vs COMPLEX(4)
p_pure => ccos
!ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible procedure attributes: Elemental
p_impure => f_elemental2
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index c63668ea7869..94b07f718ab6 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -156,17 +156,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: function results have incompatible types: INTEGER(4) vs REAL(4)
+ !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)
intProcPointer1 => null(mold=realProcPointer1)
- !WARNING: 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)
+ !WARNING: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer: function results have distinct 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
!WARNING: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
lvar = associated(pureFuncPointer, intProc)
- !ERROR: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have distinct types: REAL(4) vs INTEGER(4)
realProcPointer1 => intProc
- !WARNING: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !WARNING: Function pointer 'realprocpointer1' associated with incompatible function designator 'intproc': function results have distinct 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 c8fa19c88294..a4b2b64f0f4e 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -66,15 +66,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=': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct 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=': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct 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=': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct 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
@@ -84,7 +84,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=': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct 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())
@@ -96,7 +96,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 s02b(realfunc)
call s02b(p) ! ok
- !ERROR: Actual argument function associated with procedure dummy argument 'p=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'p=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call s02b(ip)
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02b(procptr())
@@ -169,13 +169,13 @@ subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3)
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
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc1(intfunc)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc1(dif)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc1(pif)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc1(intfunc)
!ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
call takesrealfunc2(callsub)
@@ -183,13 +183,13 @@ subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3)
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
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc2(intfunc)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc2(dif)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc2(pif)
- !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !ERROR: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
call takesrealfunc2(intfunc)
end subroutine
end module
diff --git a/flang/test/Semantics/call20.f90 b/flang/test/Semantics/call20.f90
index ee33a7e90da9..a1ecebf99257 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=': function results have incompatible types: REAL(4) vs REAL(8)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have distinct types: REAL(4) vs REAL(8)
call foo(dabs)
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have incompatible types: REAL(8) vs REAL(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': function results have distinct types: REAL(8) vs REAL(4)
call foo2(abs)
end
diff --git a/flang/test/Semantics/call25.f90 b/flang/test/Semantics/call25.f90
index 701bafe62966..d6ecd1320463 100644
--- a/flang/test/Semantics/call25.f90
+++ b/flang/test/Semantics/call25.f90
@@ -38,21 +38,21 @@ program main
external assumedlength
character(5) :: assumedlength
call subr1(explicitLength)
- !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: CHARACTER(KIND=1,LEN=5_8) vs CHARACTER(KIND=1,LEN=6_8)
call subr1(badExplicitLength)
call subr1(assumedLength)
- !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: CHARACTER(KIND=1,LEN=5_8) vs REAL(4)
call subr1(notChar)
call subr2(explicitLength)
call subr2(assumedLength)
- !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: CHARACTER(KIND=1,LEN=*) vs REAL(4)
call subr2(notChar)
call subr3(explicitLength)
!CHECK: warning: If the procedure's interface were explicit, this reference would be in error
- !CHECK: because: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !CHECK: because: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: CHARACTER(KIND=1,LEN=5_8) vs CHARACTER(KIND=1,LEN=6_8)
call subr3(badExplicitLength)
call subr3(assumedLength)
!CHECK: warning: If the procedure's interface were explicit, this reference would be in error
- !CHECK: because: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ !CHECK: because: Actual argument function associated with procedure dummy argument 'f=' is not compatible: function results have distinct types: CHARACTER(KIND=1,LEN=5_8) vs REAL(4)
call subr3(notChar)
end program
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index 56b7fd996dec..0f8d3b1c423c 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: Function pointer 'p' associated with incompatible function designator 'mod': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Function pointer 'p' associated with incompatible function designator 'mod': function results have distinct types: REAL(4) vs INTEGER(4)
p => mod
- !ERROR: Function pointer 'p' associated with incompatible function designator 'index': function results have incompatible types: REAL(4) vs INTEGER(4)
+ !ERROR: Function pointer 'p' associated with incompatible function designator 'index': function results have distinct 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