Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -2600,6 +2600,18 @@ if (!procRef) { analyzer.CheckForNullPointer( "in a non-pointer intrinsic assignment statement"); + const Expr &lhs{analyzer.GetExpr(0)}; + if (auto dyType{lhs.GetType()}; + dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1) + const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)}; + const Symbol *lastWhole{ + lastWhole0 ? &lastWhole0->GetUltimate() : nullptr}; + if (!lastWhole || !IsAllocatable(*lastWhole)) { + Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US); + } else if (evaluate::IsCoarray(*lastWhole)) { + Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US); + } + } } assignment.emplace(analyzer.MoveExpr(0), analyzer.MoveExpr(1)); if (procRef) { Index: flang/test/Semantics/assign11.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/assign11.f90 @@ -0,0 +1,12 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! 10.2.1.2p1(1) +program test + class(*), allocatable :: pa + class(*), pointer :: pp + class(*), allocatable :: pac[:] + pa = 1 ! ok + !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable + pp = 1 + !ERROR: Left-hand side of assignment may not be polymorphic if it is a coarray + pac = 1 +end Index: flang/test/Semantics/call28.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/call28.f90 @@ -0,0 +1,23 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 + +module m1 + type :: t + end type + contains + pure subroutine s1(x) + class(t), intent(in out) :: x + call s2(x) + call s3(x) + end subroutine + pure subroutine s2(x) + class(t), intent(in out) :: x + !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'x' is polymorphic in a pure subprogram + x = t() + end subroutine + pure subroutine s3(x) + !ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic + class(t), intent(out) :: x + end subroutine +end module