[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

 
 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)

flang/lib/Evaluate/characteristics.cpp

         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();
         }

flang/lib/Evaluate/type.cpp

     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) {

   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,

   if (!x || !y) {
     return false;
   } else {
-    SetOfDerivedTypePairs inProgress;
-    if (AreSameDerivedType(*x, *y, inProgress)) {
+    if (AreSameDerivedType(*x, *y)) {
       return true;
     } else {
       return isPolymorphic &&

flang/lib/Semantics/check-call.cpp

                   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(

flang/test/Semantics/assign03.f90

 
     !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

flang/test/Semantics/associated.f90

     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

flang/test/Semantics/call09.f90

     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

     !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())

     !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 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)

     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

   ! 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

   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

   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