Index: flang/include/flang/Evaluate/type.h =================================================================== --- flang/include/flang/Evaluate/type.h +++ flang/include/flang/Evaluate/type.h @@ -467,6 +467,11 @@ 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) Index: flang/lib/Evaluate/characteristics.cpp =================================================================== --- flang/lib/Evaluate/characteristics.cpp +++ flang/lib/Evaluate/characteristics.cpp @@ -925,10 +925,32 @@ 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(); } Index: flang/lib/Evaluate/type.cpp =================================================================== --- flang/lib/Evaluate/type.cpp +++ flang/lib/Evaluate/type.cpp @@ -245,8 +245,19 @@ std::set>; -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() == + y.has(); +} static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) { @@ -293,18 +304,10 @@ 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() == - y.has(); +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 @@ if (!x || !y) { return false; } else { - SetOfDerivedTypePairs inProgress; - if (AreSameDerivedType(*x, *y, inProgress)) { + if (AreSameDerivedType(*x, *y)) { return true; } else { return isPolymorphic && Index: flang/lib/Semantics/check-call.cpp =================================================================== --- flang/lib/Semantics/check-call.cpp +++ flang/lib/Semantics/check-call.cpp @@ -683,11 +683,12 @@ 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( Index: flang/test/Semantics/assign03.f90 =================================================================== --- flang/test/Semantics/assign03.f90 +++ flang/test/Semantics/assign03.f90 @@ -101,9 +101,9 @@ !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 Index: flang/test/Semantics/associated.f90 =================================================================== --- flang/test/Semantics/associated.f90 +++ flang/test/Semantics/associated.f90 @@ -156,17 +156,17 @@ 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 Index: flang/test/Semantics/call09.f90 =================================================================== --- flang/test/Semantics/call09.f90 +++ flang/test/Semantics/call09.f90 @@ -66,15 +66,15 @@ 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 @@ !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 @@ !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 @@ 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 @@ 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 Index: flang/test/Semantics/call20.f90 =================================================================== --- flang/test/Semantics/call20.f90 +++ flang/test/Semantics/call20.f90 @@ -30,9 +30,9 @@ ! 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 Index: flang/test/Semantics/call25.f90 =================================================================== --- flang/test/Semantics/call25.f90 +++ flang/test/Semantics/call25.f90 @@ -38,21 +38,21 @@ 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 Index: flang/test/Semantics/resolve46.f90 =================================================================== --- flang/test/Semantics/resolve46.f90 +++ flang/test/Semantics/resolve46.f90 @@ -34,9 +34,9 @@ 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