[flang] Refine procedure compatibility checking

[klausler]

Summary

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.

[clementval]

LGTM

flang/include/flang/Evaluate/type.h

 // Given the dynamic types and kinds of two operands, determine the common
 // type to which they must be converted in order to be compared with
 // intrinsic OPERATOR(==) or .EQV.
 std::optional<DynamicType> ComparisonType(
     const DynamicType &, const DynamicType &);
 
 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)
 #define EXPAND_FOR_EACH_REAL_KIND(M, P, S) \
   M(P, S, 2) M(P, S, 3) M(P, S, 4) M(P, S, 8) M(P, S, 10) M(P, S, 16)
 #define EXPAND_FOR_EACH_COMPLEX_KIND(M, P, S) EXPAND_FOR_EACH_REAL_KIND(M, P, S)
 #define EXPAND_FOR_EACH_CHARACTER_KIND(M, P, S) M(P, S, 1) M(P, S, 2) M(P, S, 4)
 #define EXPAND_FOR_EACH_LOGICAL_KIND(M, P, S) \

flang/lib/Evaluate/characteristics.cpp

if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
           *whyNot = "function results have distinct ranks";
         }
       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
           !AreCompatibleFunctionResultShapes(
               ifaceTypeShape->shape(), actualTypeShape->shape())) {
         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();
         }
       } else {
         return true;
       }
     } else {
       if (whyNot) {

flang/lib/Evaluate/type.cpp

 }
 
 // Compares two derived type representations to see whether they both
 // represent the "same type" in the sense of section 7.5.2.4.
 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) {
   const auto &xSymbol{x.typeSymbol()};
   const auto &ySymbol{y.typeSymbol()};
   if (&x == &y || xSymbol == ySymbol) {
     return true;
   }
if (xLookup == xSymbol.scope()->end() ||
         yLookup == ySymbol.scope()->end() ||
         !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
       return false;
     }
   }
   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,
     const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
   if (!x || !y) {
     return false;
   } else {
-    SetOfDerivedTypePairs inProgress;
-    if (AreSameDerivedType(*x, *y, inProgress)) {
+    if (AreSameDerivedType(*x, *y)) {
       return true;
     } else {
       return isPolymorphic &&
           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
     }
   }
 }
 

flang/lib/Semantics/check-call.cpp

if (auto argChars{characteristics::DummyArgument::FromActual(
             }
           } 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()) {
+                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(
                     "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
                     dummyName);
               }
             }
           }

flang/test/Semantics/assign03.f90

subroutine s5
     !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
     sp_pure => s_impure1
     sp_pure => s_pure1 ! OK, same characteristics
     !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental
     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': 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
 
     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes: BindC
     sp_impure => s_impure2
     !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

flang/test/Semantics/associated.f90

subroutine test()
     !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
     lvar = associated (intPointerVar1, intFunc)
     !ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
     intPointerVar1 => intFunc
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
     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
     !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
     subProcPointer => intProc
     !WARNING: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
     lvar = associated(subProcPointer, intProc)
     !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'

flang/test/Semantics/call09.f90

contains
   subroutine test1 ! 15.5.2.9(5)
     intrinsic :: sin
     procedure(realfunc), pointer :: p
     procedure(intfunc), pointer :: ip
     integer, pointer :: intPtr
     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
     call s01(null(intPtr))
     !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
     call s01(B"0101")
     !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())
     call s02(null()) ! ok
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s05(null())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(sin)
     !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())
     call s02b(null())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02b(sin)
   end subroutine
 
subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3)
     !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
+    !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)
     !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
+    !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

flang/test/Semantics/call20.f90

! are correctly validated against actual arguments explicit interface.
   end interface
 
   ! OK
   call foo(abs)
 
   ! 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

flang/test/Semantics/call25.f90

subroutine subr3(f)
   print *, f('abcde')
 end subroutine
 
 program main
   use m
   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

flang/test/Semantics/resolve46.f90

program main
   procedure(chrcmp), pointer :: s => llt
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
   procedure(cos), pointer :: t => bessel_j0
   procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
   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
   !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
   u => llt
 end program main