diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index e396ece303103..624a8e1a34ee5 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1478,6 +1478,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments, } if (const auto &targetArg{arguments[1]}) { // The standard requires that the TARGET= argument, when present, + // be type compatible with the POINTER= for a data pointer. In + // the case of procedure pointers, the standard requires that it // be a valid RHS for a pointer assignment that has the POINTER= // argument as its LHS. Some popular compilers misinterpret this // requirement more strongly than necessary, and actually validate @@ -1584,7 +1586,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments, } if (const auto pointerType{pointerArg->GetType()}) { if (const auto targetType{targetArg->GetType()}) { - ok = pointerType->IsTkCompatibleWith(*targetType); + ok = pointerType->IsTkCompatibleWith(*targetType) || + targetType->IsTkCompatibleWith(*pointerType); } } } else { diff --git a/flang/test/Semantics/bug125774.f90 b/flang/test/Semantics/bug125774.f90 new file mode 100644 index 0000000000000..9844f1ec5eb1e --- /dev/null +++ b/flang/test/Semantics/bug125774.f90 @@ -0,0 +1,15 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +type t +end type +real, pointer :: rptr +type(t), pointer :: tptr +class(*), pointer :: ulpp +print *, associated(rptr, ulpp) +print *, associated(ulpp, rptr) +print *, associated(tptr, ulpp) +print *, associated(ulpp, tptr) +!ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target +print *, associated(rptr, tptr) +!ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target +print *, associated(tptr, rptr) +end