diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -303,6 +303,13 @@ } 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 @@ } } } - 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 --- a/flang/test/Semantics/argshape01.f90 +++ b/flang/test/Semantics/argshape01.f90 @@ -8,27 +8,60 @@ 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 @@ !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 --- a/flang/test/Semantics/assign12.f90 +++ b/flang/test/Semantics/assign12.f90 @@ -12,6 +12,9 @@ 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 @@ 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