diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -48,8 +48,10 @@ if (const auto *expr{arg.UnwrapExpr()}) { if (IsBOZLiteral(*expr)) { messages.Say("BOZ argument requires an explicit interface"_err_en_US); - } - if (auto named{evaluate::ExtractNamedEntity(*expr)}) { + } else if (evaluate::IsNullPointer(*expr)) { + messages.Say( + "Null pointer argument requires an explicit interface"_err_en_US); + } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) { const Symbol &symbol{named->GetLastSymbol()}; if (symbol.Corank() > 0) { messages.Say( @@ -499,6 +501,16 @@ } } } + + // NULL(MOLD=) checking for non-intrinsic procedures + bool dummyIsOptional{ + dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)}; + bool actualIsNull{evaluate::IsNullPointer(actual)}; + if (!intrinsic && !dummyIsPointer && !dummyIsOptional && actualIsNull) { + messages.Say( + "Actual argument associated with %s may not be null pointer %s"_err_en_US, + dummyName, actual.AsFortran()); + } } static void CheckProcedureArg(evaluate::ActualArgument &arg, @@ -641,8 +653,10 @@ } else if (object.type.type().IsTypelessIntrinsicArgument() && evaluate::IsNullPointer(*expr)) { // ok, ASSOCIATED(NULL()) - } else if (object.attrs.test( - characteristics::DummyDataObject::Attr::Pointer) && + } else if ((object.attrs.test(characteristics::DummyDataObject:: + Attr::Pointer) || + object.attrs.test(characteristics:: + DummyDataObject::Attr::Optional)) && evaluate::IsNullPointer(*expr)) { // ok, FOO(NULL()) } else { diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -174,8 +174,7 @@ if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape, "pointer", "function result", false /*elemental*/, evaluate::CheckConformanceFlags::BothDeferredShape)) { - msg = "%s is associated with the result of a reference to function '%s'" - " whose pointer result has an incompatible type or shape"_err_en_US; + return false; // IsCompatibleWith() emitted message } } if (msg) { diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90 --- a/flang/test/Semantics/null01.f90 +++ b/flang/test/Semantics/null01.f90 @@ -8,6 +8,10 @@ subroutine s1(j) integer, intent(in) :: j end subroutine + subroutine canbenull(x, y) + integer, intent(in), optional :: x + real, intent(in), pointer :: y + end function f0() real :: f0 end function @@ -25,6 +29,7 @@ procedure(s1), pointer :: f3 end function end interface + external implicit type :: dt0 integer, pointer :: ip0 end type dt0 @@ -62,10 +67,8 @@ dt0x = dt0(ip0=null(ip0)) dt0x = dt0(ip0=null(mold=ip0)) !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)' - !ERROR: pointer 'ip0' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape dt0x = dt0(ip0=null(mold=rp0)) !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)' - !ERROR: pointer 'ip1' is associated with the result of a reference to function 'null' whose pointer result has an incompatible type or shape dt1x = dt1(ip1=null(mold=rp1)) dt2x = dt2(pps0=null()) dt2x = dt2(pps0=null(mold=dt2x%pps0)) @@ -74,4 +77,10 @@ !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer dt3x = dt3(pps1=null(mold=dt2x%pps0)) dt3x = dt3(pps1=null(mold=dt3x%pps1)) + call canbenull(null(), null()) ! fine + call canbenull(null(mold=ip0), null(mold=rp0)) ! fine + !ERROR: Null pointer argument requires an explicit interface + call implicit(null()) + !ERROR: Null pointer argument requires an explicit interface + call implicit(null(mold=ip0)) end subroutine test