[flang] Strengthen procedure compatibility checking

Add more checks to procedure compatibility testing for procedure pointer
assignments, actual procedure arguments, &c.  Specifically, don't
allow corresponding dummy data objects to differ in their use
of polymorphism, assumed size arrays, or assumed shape arrays.

Differential Revision: https://reviews.llvm.org/D155974

3 files changed, 52 insertions, 1 deletions

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 1bd8666..4c03665 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -303,6 +303,13 @@ bool DummyDataObject::IsCompatibleWith(
     }
     return false;
   }
+  if (type.type().IsPolymorphic() != actual.type.type().IsPolymorphic()) {
+    if (whyNot) {
+      *whyNot = "incompatible dummy data object polymorphism: "s +
+          type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
+    }
+    return false;
+  }
   if (type.type().category() == TypeCategory::Character) {
     if (actual.type.type().IsAssumedLengthCharacter() !=
         type.type().IsAssumedLengthCharacter()) {
@@ -329,7 +336,7 @@ bool DummyDataObject::IsCompatibleWith(
       }
     }
   }
-  if (attrs != actual.attrs) {
+  if (attrs != actual.attrs || type.attrs() != actual.type.attrs()) {
     if (whyNot) {
       *whyNot = "incompatible dummy data object attributes";
     }
diff --git a/flang/test/Semantics/argshape01.f90 b/flang/test/Semantics/argshape01.f90
index 42ba0fa..b57641a 100644
--- a/flang/test/Semantics/argshape01.f90
+++ b/flang/test/Semantics/argshape01.f90
@@ -8,27 +8,60 @@ module m
   subroutine s2(a)
     real, intent(in) :: a(3,2)
   end
+  subroutine s3(a)
+    real, intent(in) :: a(3,*)
+  end
+  subroutine s4(a)
+    real, intent(in) :: a(:,:)
+  end
+  subroutine s5(a)
+    real, intent(in) :: a(..)
+  end
   subroutine s1c(s)
     procedure(s1) :: s
   end
   subroutine s2c(s)
     procedure(s2) :: s
   end
+  subroutine s3c(s)
+    procedure(s3) :: s
+  end
+  subroutine s4c(s)
+    procedure(s4) :: s
+  end
+  subroutine s5c(s)
+    procedure(s5) :: s
+  end
 end
 
 program main
   use m
   procedure(s1), pointer :: ps1
   procedure(s2), pointer :: ps2
+  procedure(s3), pointer :: ps3
+  procedure(s4), pointer :: ps4
+  procedure(s5), pointer :: ps5
   call s1c(s1)
   !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
   call s1c(s2)
   !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(s3)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object attributes
+  call s1c(s4)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(s5)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
   call s2c(s1)
   call s2c(s2)
   ps1 => s1
   !ERROR: Procedure pointer 'ps1' associated with incompatible procedure designator 's2': incompatible dummy argument #1: incompatible dummy data object shapes
   ps1 => s2
+  !ERROR: Procedure pointer 'ps1' associated with incompatible procedure designator 's3': incompatible dummy argument #1: incompatible dummy data object shapes
+  ps1 => s3
+  !ERROR: Procedure pointer 'ps1' associated with incompatible procedure designator 's4': incompatible dummy argument #1: incompatible dummy data object attributes
+  ps1 => s4
+  !ERROR: Procedure pointer 'ps1' associated with incompatible procedure designator 's5': incompatible dummy argument #1: incompatible dummy data object shapes
+  ps1 => s5
   !ERROR: Procedure pointer 'ps2' associated with incompatible procedure designator 's1': incompatible dummy argument #1: incompatible dummy data object shapes
   ps2 => s1
   ps2 => s2
@@ -36,6 +69,12 @@ program main
   !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
   call s1c(ps2)
   !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(ps3)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object attributes
+  call s1c(ps4)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(ps5)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
   call s2c(ps1)
   call s2c(ps2)
 end
diff --git a/flang/test/Semantics/assign12.f90 b/flang/test/Semantics/assign12.f90
index 30feb6b..85898a1 100644
--- a/flang/test/Semantics/assign12.f90
+++ b/flang/test/Semantics/assign12.f90
@@ -12,6 +12,9 @@ module m
   subroutine extendedSub(x)
     class(extended), intent(in) :: x
   end
+  subroutine baseSubmono(x)
+    type(base), intent(in) :: x
+  end
   subroutine test
     procedure(baseSub), pointer :: basePtr
     procedure(extendedSub), pointer :: extendedPtr
@@ -28,5 +31,7 @@ module m
     extendedVar = extended(extendedSub)
     !ERROR: Procedure pointer 'basecomponent' associated with incompatible procedure designator 'extendedptr': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
     extendedVar = extended(extendedPtr)
+    !ERROR: Procedure pointer 'baseptr' associated with incompatible procedure designator 'basesubmono': incompatible dummy argument #1: incompatible dummy data object polymorphism: base vs CLASS(base)
+    basePtr => baseSubmono
   end
 end