[flang-commits] [flang] f7e4304 - [flang] Strengthen procedure compatibility checking

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-07-21T14:44:10-07:00
New Revision: f7e4304120506c9973a5ac939e06c106d8816911

URL: https://github.com/llvm/llvm-project/commit/f7e4304120506c9973a5ac939e06c106d8816911
DIFF: https://github.com/llvm/llvm-project/commit/f7e4304120506c9973a5ac939e06c106d8816911.diff

LOG: [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

Added: 
    

Modified: 
    flang/lib/Evaluate/characteristics.cpp
    flang/test/Semantics/argshape01.f90
    flang/test/Semantics/assign12.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 1bd86664c875f7..4c036652711657 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 42ba0fab4a5e56..b57641a1b898b3 100644
--- a/flang/test/Semantics/argshape01.f90
+++ b/flang/test/Semantics/argshape01.f90
@@ -8,27 +8,60 @@ subroutine s1(a)
   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 30feb6b5b5b601..85898a1eba8960 100644
--- a/flang/test/Semantics/assign12.f90
+++ b/flang/test/Semantics/assign12.f90
@@ -12,6 +12,9 @@ subroutine baseSub(x)
   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 @@ subroutine test
     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