[flang] More checking of NULL pointer actual arguments

Catch additional missing error cases for typed and untyped NULL actual arguments to non-intrinsic procedures in cases of explicit and implicit interfaces. Differential Revision: https://reviews.llvm.org/D110003
llvm · Sep 17, 2021 · bcb2591 · bcb2591
1 parent 757384a
commit bcb2591
Show file tree

Hide file tree

Showing 3 changed files with 30 additions and 8 deletions.
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
@@ -48,8 +48,10 @@ static void CheckImplicitInterfaceArg(
   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 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       }
     }
   }
+
+  // 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 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
               } 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
@@ -174,8 +174,7 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
     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
@@ -8,6 +8,10 @@ subroutine s0
     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 @@ function f3()
       procedure(s1), pointer :: f3
     end function
   end interface
+  external implicit
   type :: dt0
     integer, pointer :: ip0
   end type dt0
@@ -62,10 +67,8 @@ function f3()
   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 @@ function f3()
   !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