[flang] More checking of NULL pointer actual arguments

[klausler]

Summary

Catch additional missing error cases for typed and untyped
NULL actual arguments to non-intrinsic procedures in cases
of explicit and implicit interfaces.

[PeteSteinfeld]

LGTM
All builds, tests, and looks good.

flang/lib/Semantics/check-call.cpp

if (type->IsAssumedType()) {
         messages.Say(
             "Parameterized derived type argument requires an explicit interface"_err_en_US);
       }
     }
   }
   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(
             "Coarray argument requires an explicit interface"_err_en_US);
       }
       if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
         if (details->IsAssumedRank()) {
           messages.Say(
if (actualRank == dummy.type.Rank() && !actualIsContiguous) {
             dummyName);
       } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
         messages.Say(
             "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
             dummyName);
       }
     }
   }
+
+  // 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,
     const characteristics::Procedure &proc,
     const characteristics::DummyProcedure &dummy, const std::string &dummyName,
     evaluate::FoldingContext &context) {
   parser::ContextualMessages &messages{context.messages()};
   const characteristics::Procedure &interface { dummy.procedure.value() };
std::visit(
                 CheckExplicitDataArg(object, dummyName, *expr, *type,
                     isElemental, context, scope, intrinsic);
               } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                   IsBOZLiteral(*expr)) {
                 // ok
               } 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 {
                 messages.Say(
                     "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
                     expr->AsFortran(), dummyName);
               }
             } else {

flang/lib/Semantics/pointer-assignment.cpp

if (!funcResult) {
     msg = "CONTIGUOUS %s is associated with the result of reference to"
           " function '%s' that is not contiguous"_err_en_US;
   } else if (lhsType_) {
     const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
     CHECK(frTypeAndShape);
     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) {
     auto restorer{common::ScopedSet(lhs_, symbol)};
     Say(*msg, description_, funcName);
     return false;
   }
   return true;

flang/test/Semantics/null01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! NULL() intrinsic function error tests
 
 subroutine test
   interface
     subroutine s0
     end subroutine
     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
     function f1(x)
       real :: f1
       real, intent(inout) :: x
     end function
     function f2(p)
       import s0
       real :: f1
       procedure(s0), pointer, intent(inout) :: p
     end function
     function f3()
       import s1
       procedure(s1), pointer :: f3
     end function
   end interface
+  external implicit
   type :: dt0
     integer, pointer :: ip0
   end type dt0
   type :: dt1
     integer, pointer :: ip1(:)
   end type dt1
   type :: dt2
     procedure(s0), pointer, nopass :: pps0
subroutine test
   ip0 => null(mold=1)
   !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
   ip0 => null(mold=j)
   dt0x = dt0(null())
   dt0x = dt0(ip0=null())
   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))
   !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer
   dt2x = dt2(pps0=null(mold=dt3x%pps1))
   !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