[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
GitOrigin-RevId: bcb2591b6ca00365cb9f99efafeb3bfe8682f002
diff --git a/lib/Semantics/check-call.cpp b/lib/Semantics/check-call.cpp
index b0c8fcd..e6a8434 100644
--- a/lib/Semantics/check-call.cpp
+++ b/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/lib/Semantics/pointer-assignment.cpp b/lib/Semantics/pointer-assignment.cpp
index afa1552..7003242 100644
--- a/lib/Semantics/pointer-assignment.cpp
+++ b/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/test/Semantics/null01.f90 b/test/Semantics/null01.f90
index 73ee760..8c89a0b 100644
--- a/test/Semantics/null01.f90
+++ b/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
