diff options
author | Peter Klausler <pklausler@nvidia.com> | 2023-07-20 11:46:31 -0700 |
---|---|---|
committer | Peter Klausler <pklausler@nvidia.com> | 2023-07-21 14:44:10 -0700 |
commit | f7e4304120506c9973a5ac939e06c106d8816911 (patch) | |
tree | 5e0a61433ba090e6579bb687b9b6c4584d881768 /flang | |
parent | f4381d46445709fda9b8ec6c8f85d019de2dad22 (diff) | |
download | llvm-f7e4304120506c9973a5ac939e06c106d8816911.zip llvm-f7e4304120506c9973a5ac939e06c106d8816911.tar.gz llvm-f7e4304120506c9973a5ac939e06c106d8816911.tar.bz2 |
[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
Diffstat (limited to 'flang')
-rw-r--r-- | flang/lib/Evaluate/characteristics.cpp | 9 | ||||
-rw-r--r-- | flang/test/Semantics/argshape01.f90 | 39 | ||||
-rw-r--r-- | flang/test/Semantics/assign12.f90 | 5 |
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 |