[flang] Allow NULL() actual argument for procedure pointer dummy argument with unspecified intent

[klausler]

Summary

A NULL() pointer is a valid actual argument for a procedure pointer dummy
argument whose intent is INTENT(IN); it should also be acceptable for a
procedure pointer dummy argument with unspecified intent.

Also make it possible to discern null object pointers from null procedure
pointers, so that an attempt to use one in place of the other in a context
where the distinction matters will still elicit an error.

flang/include/flang/Evaluate/tools.h

 
 bool IsAllocatableDesignator(const Expr<SomeType> &);
 
 // Procedure and pointer detection predicates
 bool IsProcedure(const Expr<SomeType> &);
 bool IsFunction(const Expr<SomeType> &);
 bool IsProcedurePointerTarget(const Expr<SomeType> &);
 bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD=
+bool IsNullObjectPointer(const Expr<SomeType> &);
+bool IsNullProcedurePointer(const Expr<SomeType> &);
 bool IsNullPointer(const Expr<SomeType> &);
 bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
 
 // Can Expr be passed as absent to an optional dummy argument.
 // See 15.5.2.12 point 1 for more details.
 bool MayBePassedAsAbsentOptional(const Expr<SomeType> &, FoldingContext &);
 
 // Extracts the chain of symbols from a designator, which has perhaps been

flang/lib/Evaluate/check-expression.cpp

bool IsConstantStructureConstructorComponent(
       const Symbol &, const Expr<SomeType> &) const;
   bool IsConstantExprShape(const Shape &) const;
 };
 
 template <bool INVARIANT>
 bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
     const Symbol &component, const Expr<SomeType> &expr) const {
   if (IsAllocatable(component)) {
-    return IsNullPointer(expr);
+    return IsNullObjectPointer(expr);
   } else if (IsPointer(component)) {
     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
         IsInitialProcedureTarget(expr);
   } else {
     return (*this)(expr);
   }
 }
 
if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
     return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
   }
 }
 
 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
     return IsInitialProcedureTarget(*proc);
   } else {
-    return IsNullPointer(expr);
+    return IsNullProcedurePointer(expr);
   }
 }
 
 class ArrayConstantBoundChanger {
 public:
   ArrayConstantBoundChanger(ConstantSubscripts &&lbounds)
       : lbounds_{std::move(lbounds)} {}
 

flang/lib/Evaluate/intrinsics.cpp

if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
                     msg->set_severity(parser::Severity::Warning);
                     AttachDeclaration(
                         context.messages().Say(std::move(*msg),
                             "pointer '" + pointerSymbol->name().ToString() +
                                 "'",
                             targetName, whyNot),
                         *pointerSymbol);
                   }
-                } else {
+                } else if (!IsNullProcedurePointer(*targetExpr)) {
                   // procedure pointer and object target
-                  if (!IsNullPointer(*targetExpr)) {
-                    AttachDeclaration(
-                        context.messages().Say(
-                            "POINTER= argument '%s' is a procedure "
-                            "pointer but the TARGET= argument '%s' is not a "
-                            "procedure or procedure pointer"_err_en_US,
-                            pointerSymbol->name(), targetName),
-                        *pointerSymbol);
-                  }
-                }
               } else if (targetProc) {
                 // object pointer and procedure target
                 AttachDeclaration(
                     context.messages().Say(
                         "POINTER= argument '%s' is an object pointer "
                         "but the TARGET= argument '%s' is a "
                         "procedure designator"_err_en_US,
                         pointerSymbol->name(), targetName),

flang/lib/Evaluate/tools.cpp

 template <typename T>
 inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
   return common::visit(
       [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
 }
 
 // IsObjectPointer()
 bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
-  if (IsNullPointer(expr)) {
+  if (IsNullObjectPointer(expr)) {
     return true;
   } else if (IsProcedurePointerTarget(expr)) {
     return false;
   } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
     return IsVariable(*funcRef);
   } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
     return IsPointer(symbol->GetUltimate());
   } else {
     return false;
   }
 }
 
 bool IsBareNullPointer(const Expr<SomeType> *expr) {
   return expr && std::holds_alternative<NullPointer>(expr->u);
 }
 
-// IsNullPointer()
-struct IsNullPointerHelper {
+// IsNullObjectPointetr, IsNullProcedurePointer(), IsNullPointer()
+template <bool IS_PROC_PTR> struct IsNullPointerHelper {
   template <typename A> bool operator()(const A &) const { return false; }
+  bool operator()(const ProcedureRef &call) const {
+    if constexpr (IS_PROC_PTR) {
+      const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
+      return intrinsic &&
+          intrinsic->characteristics.value().attrs.test(
+              characteristics::Procedure::Attr::NullPointer);
+    } else {
+      return false;
+    }
+  }
   template <typename T> bool operator()(const FunctionRef<T> &call) const {
+    if constexpr (IS_PROC_PTR) {
+      return false;
+    } else {
       const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
       return intrinsic &&
           intrinsic->characteristics.value().attrs.test(
               characteristics::Procedure::Attr::NullPointer);
     }
+  }
   bool operator()(const NullPointer &) const { return true; }
   template <typename T> bool operator()(const Parentheses<T> &x) const {
     return (*this)(x.left());
   }
   template <typename T> bool operator()(const Expr<T> &x) const {
     return common::visit(*this, x.u);
   }
 };
 
+bool IsNullObjectPointer(const Expr<SomeType> &expr) {
+  return IsNullPointerHelper<false>{}(expr);
+}
+bool IsNullProcedurePointer(const Expr<SomeType> &expr) {
+  return IsNullPointerHelper<true>{}(expr);
+}
 bool IsNullPointer(const Expr<SomeType> &expr) {
-  return IsNullPointerHelper{}(expr);
+  return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);
 }
 
 // GetSymbolVector()
 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
     return (*this)(details->expr());
   } else {
     return {x.GetUltimate()};

flang/lib/Semantics/check-call.cpp

if (auto argChars{characteristics::DummyArgument::FromActual(
         messages.Say(
             "Actual argument associated with procedure %s is typeless"_err_en_US,
             dummyName);
       }
     }
     if (interface.HasExplicitInterface() && dummyIsPointer &&
         dummy.intent != common::Intent::In) {
       const Symbol *last{GetLastSymbol(*expr)};
-      if (!(last && IsProcedurePointer(*last))) {
+      if (!(last && IsProcedurePointer(*last)) &&
+          !(dummy.intent == common::Intent::Default &&
+              IsNullProcedurePointer(*expr))) {
         // 15.5.2.9(5) -- dummy procedure POINTER
         // Interface compatibility has already been checked above
         messages.Say(
             "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
             dummyName);
       }
     }
   } else {
common::visit(
                       object.type.Rank() == 0 && proc.IsElemental()};
                   CheckExplicitDataArg(object, dummyName, *expr, *type,
                       isElemental, context, scope, intrinsic,
                       allowActualArgumentConversions);
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     IsBOZLiteral(*expr)) {
                   // ok
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
-                    evaluate::IsNullPointer(*expr)) {
+                    evaluate::IsNullObjectPointer(*expr)) {
                   // ok, ASSOCIATED(NULL())
                 } else if ((object.attrs.test(characteristics::DummyDataObject::
                                     Attr::Pointer) ||
                                object.attrs.test(characteristics::
                                        DummyDataObject::Attr::Optional)) &&
-                    evaluate::IsNullPointer(*expr)) {
+                    evaluate::IsNullObjectPointer(*expr)) {
                   // ok, FOO(NULL())
                 } else if (object.attrs.test(characteristics::DummyDataObject::
                                    Attr::Allocatable) &&
                     evaluate::IsNullPointer(*expr)) {
                   // Unsupported extension that more or less naturally falls
                   // out of other Fortran implementations that pass separate
                   // base address and descriptor address physical arguments
                   messages.Say(

flang/lib/Semantics/data-to-inits.cpp

if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     CHECK(IsProcedurePointer(symbol));
     auto &mutableProc{const_cast<ProcEntityDetails &>(*proc)};
     if (MaybeExpr expr{initialization.image.AsConstantPointer()}) {
       if (const auto *procDesignator{
               std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
         CHECK(!procDesignator->GetComponent());
         mutableProc.set_init(DEREF(procDesignator->GetSymbol()));
       } else {
-        CHECK(evaluate::IsNullPointer(*expr));
+        CHECK(evaluate::IsNullProcedurePointer(*expr));
         mutableProc.set_init(nullptr);
       }
     } else {
       mutableProc.set_init(nullptr);
     }
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     auto &mutableObject{const_cast<ObjectEntityDetails &>(*object)};
     if (IsPointer(symbol)) {

flang/test/Semantics/call09.f90

contains
   end subroutine
   subroutine s03(p)
     procedure(realfunc) :: p
   end subroutine
   subroutine s04(p)
     !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
     procedure(realfunc), intent(in) :: p
   end subroutine
+  subroutine s05(p)
+    procedure(realfunc), pointer, intent(in out) :: p
+  end subroutine
 
   subroutine selemental1(p)
     procedure(cos) :: p ! ok
   end subroutine
 
   real elemental function elemfunc(x)
     real, intent(in) :: x
     elemfunc = x
subroutine test1 ! 15.5.2.9(5)
     call s01(B"0101")
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(realfunc)
     call s02(p) ! ok
     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have incompatible types: REAL(4) vs INTEGER(4)
     call s02(ip)
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(procptr())
+    call s02(null()) ! ok
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
-    call s02(null())
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
-    call s02(null(p))
+    call s05(null())
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(sin)
   end subroutine
 
   subroutine callsub(s)
     call s
   end subroutine
   subroutine takesrealfunc1(f)