[flang] Further work on NULL(MOLD=allocatable)

Refine handling of NULL(...) in semantics to properly distinguish
NULL(), NULL(objectPointer), NULL(procPointer), and NULL(allocatable)
from each other in relevant contexts.

Add IsNullAllocatable() and IsNullPointerOrAllocatable() utility functions.
IsNullAllocatable() is true only for NULL(allocatable); it is false
for a bare NULL(), which can be detected independently with IsBareNullPointer().

IsNullPointer() now returns false for NULL(allocatable).

ALLOCATED(NULL(allocatable)) now works, and folds to .FALSE.

These utilities were modified to accept const pointer arguments rather
than const references; I usually prefer this style when the result should
clearly be false for a null argument (in the C sense), and it helped me
find all of their use sites in the code.

Author: klausler

flang/include/flang/Evaluate/characteristics.h

@@ -349,8 +349,8 @@ struct FunctionResult {
 
 // 15.3.1
 struct Procedure {
-  ENUM_CLASS(
-      Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, Subroutine)
+  ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer,
+      NullAllocatable, Subroutine)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
   Procedure(){};
   Procedure(FunctionResult &&, DummyArguments &&, Attrs);

flang/include/flang/Evaluate/tools.h

@@ -1059,9 +1059,11 @@ bool IsProcedurePointer(const Expr<SomeType> &);
 bool IsProcedure(const Expr<SomeType> &);
 bool IsProcedurePointerTarget(const Expr<SomeType> &);
 bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
-bool IsNullObjectPointer(const Expr<SomeType> &);
-bool IsNullProcedurePointer(const Expr<SomeType> &);
-bool IsNullPointer(const Expr<SomeType> &);
+bool IsNullObjectPointer(const Expr<SomeType> *); // NULL() or NULL(objptr)
+bool IsNullProcedurePointer(const Expr<SomeType> *); // NULL() or NULL(procptr)
+bool IsNullPointer(const Expr<SomeType> *); // NULL() or NULL(pointer)
+bool IsNullAllocatable(const Expr<SomeType> *); // NULL(allocatable)
+bool IsNullPointerOrAllocatable(const Expr<SomeType> *); // NULL of any form
 bool IsObjectPointer(const Expr<SomeType> &);
 
 // Can Expr be passed as absent to an optional dummy argument.

flang/lib/Evaluate/check-expression.cpp

@@ -100,9 +100,9 @@ template <bool INVARIANT>
 bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
     const Symbol &component, const Expr<SomeType> &expr) const {
   if (IsAllocatable(component)) {
-    return IsNullObjectPointer(expr);
+    return IsNullObjectPointer(&expr);
   } else if (IsPointer(component)) {
-    return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
+    return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) ||
         IsInitialProcedureTarget(expr);
   } else {
     return (*this)(expr);
@@ -194,7 +194,7 @@ struct IsActuallyConstantHelper {
       const bool compIsConstant{(*this)(y)};
       // If an allocatable component is initialized by a constant,
       // the structure constructor is not a constant.
-      if ((!compIsConstant && !IsNullPointer(y)) ||
+      if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) ||
           (compIsConstant && IsAllocatable(sym))) {
         return false;
       }
@@ -311,7 +311,9 @@ class IsInitialDataTargetHelper
   bool operator()(const ProcedureRef &x) const {
     if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {
       return intrinsic->characteristics.value().attrs.test(
-          characteristics::Procedure::Attr::NullPointer);
+                 characteristics::Procedure::Attr::NullPointer) ||
+          intrinsic->characteristics.value().attrs.test(
+              characteristics::Procedure::Attr::NullAllocatable);
     }
     return false;
   }
@@ -388,7 +390,7 @@ bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
     return IsInitialProcedureTarget(*proc);
   } else {
-    return IsNullProcedurePointer(expr);
+    return IsNullProcedurePointer(&expr);
   }
 }
 

flang/lib/Evaluate/fold-logical.cpp

@@ -652,21 +652,18 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
   if (name == "all") {
     return FoldAllAnyParity(
         context, std::move(funcRef), &Scalar<T>::AND, Scalar<T>{true});
+  } else if (name == "allocated") {
+    if (IsNullAllocatable(args[0]->UnwrapExpr())) {
+      return Expr<T>{false};
+    }
   } else if (name == "any") {
     return FoldAllAnyParity(
         context, std::move(funcRef), &Scalar<T>::OR, Scalar<T>{false});
   } else if (name == "associated") {
-    bool gotConstant{true};
-    const Expr<SomeType> *firstArgExpr{args[0]->UnwrapExpr()};
-    if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) {
-      gotConstant = false;
-    } else if (args[1]) { // There's a second argument
-      const Expr<SomeType> *secondArgExpr{args[1]->UnwrapExpr()};
-      if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) {
-        gotConstant = false;
-      }
+    if (IsNullPointer(args[0]->UnwrapExpr()) ||
+        (args[1] && IsNullPointer(args[1]->UnwrapExpr()))) {
+      return Expr<T>{false};
     }
-    return gotConstant ? Expr<T>{false} : Expr<T>{std::move(funcRef)};
   } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {
     static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
 

flang/lib/Evaluate/fold.cpp

@@ -73,7 +73,7 @@ Expr<SomeDerived> FoldOperation(
   for (auto &&[symbol, value] : std::move(structure)) {
     auto expr{Fold(context, std::move(value.value()))};
     if (IsPointer(symbol)) {
-      if (IsNullPointer(expr)) {
+      if (IsNullPointer(&expr)) {
         // Handle x%c when x designates a named constant of derived
         // type and %c is NULL() in that constant.
         expr = Expr<SomeType>{NullPointer{}};
@@ -86,9 +86,10 @@ Expr<SomeDerived> FoldOperation(
       // F2023: 10.1.12 (3)(a)
       // If comp-spec is not null() for the allocatable component the
       // structure constructor is not a constant expression.
-      isConstant &= IsNullPointer(expr);
+      isConstant &= IsNullAllocatable(&expr) || IsBareNullPointer(&expr);
     } else {
-      isConstant &= IsActuallyConstant(expr) || IsNullPointer(expr);
+      isConstant &=
+          IsActuallyConstant(expr) || IsNullPointerOrAllocatable(&expr);
       if (auto valueShape{GetConstantExtents(context, expr)}) {
         if (auto componentShape{GetConstantExtents(context, symbol)}) {
           if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {

flang/lib/Evaluate/intrinsics.cpp

@@ -247,8 +247,10 @@ ENUM_CLASS(Optionality, required,
 )
 
 ENUM_CLASS(ArgFlag, none,
-    canBeNull, // actual argument can be NULL(with or without MOLD=)
-    canBeMoldNull, // actual argument can be NULL(with MOLD=)
+    canBeNullPointer, // actual argument can be NULL(with or without
+                      // MOLD=pointer)
+    canBeMoldNull, // actual argument can be NULL(MOLD=any)
+    canBeNullAllocatable, // actual argument can be NULL(MOLD=allocatable)
     defaultsToSameKind, // for MatchingDefaultKIND
     defaultsToSizeKind, // for SizeDefaultKIND
     defaultsToDefaultForResult, // for DefaultingKIND
@@ -343,8 +345,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         Rank::dimReduced, IntrinsicClass::transformationalFunction},
     {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical,
         Rank::elemental, IntrinsicClass::inquiryFunction},
-    {"allocated", {{"array", AnyData, Rank::anyOrAssumedRank}}, DefaultLogical,
-        Rank::elemental, IntrinsicClass::inquiryFunction},
+    {"allocated",
+        {{"array", AnyData, Rank::anyOrAssumedRank, Optionality::required,
+            common::Intent::In, {ArgFlag::canBeNullAllocatable}}},
+        DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
     {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
     {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
         Rank::dimReduced, IntrinsicClass::transformationalFunction},
@@ -353,10 +357,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"asinh", {{"x", SameFloating}}, SameFloating},
     {"associated",
         {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required,
-             common::Intent::In, {ArgFlag::canBeNull}},
+             common::Intent::In, {ArgFlag::canBeNullPointer}},
             {"target", Addressable, Rank::anyOrAssumedRank,
                 Optionality::optional, common::Intent::In,
-                {ArgFlag::canBeNull}}},
+                {ArgFlag::canBeNullPointer}}},
         DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
     {"atan", {{"x", SameFloating}}, SameFloating},
     {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
@@ -1883,9 +1887,9 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
           d.keyword);
       return std::nullopt;
     }
-    if (!d.flags.test(ArgFlag::canBeNull)) {
-      if (const auto *expr{arg->UnwrapExpr()}; expr && IsNullPointer(*expr)) {
-        if (!IsBareNullPointer(expr) && IsNullObjectPointer(*expr) &&
+    if (!d.flags.test(ArgFlag::canBeNullPointer)) {
+      if (const auto *expr{arg->UnwrapExpr()}; IsNullPointer(expr)) {
+        if (!IsBareNullPointer(expr) && IsNullObjectPointer(expr) &&
             d.flags.test(ArgFlag::canBeMoldNull)) {
           // ok
         } else {
@@ -1896,6 +1900,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         }
       }
     }
+    if (!d.flags.test(ArgFlag::canBeNullAllocatable) &&
+        IsNullAllocatable(arg->UnwrapExpr())) {
+      messages.Say(arg->sourceLocation(),
+          "A NULL() allocatable is not allowed for '%s=' intrinsic argument"_err_en_US,
+          d.keyword);
+      return std::nullopt;
+    }
     if (d.flags.test(ArgFlag::notAssumedSize)) {
       if (auto named{ExtractNamedEntity(*arg)}) {
         if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) {
@@ -2853,14 +2864,15 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
             "MOLD= argument to NULL() must not be assumed-rank"_err_en_US);
       }
       bool isProcPtrTarget{
-          IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(*mold)};
+          IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(mold)};
       if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) {
         characteristics::DummyArguments args;
         std::optional<characteristics::FunctionResult> fResult;
+        bool isAllocatableMold{false};
         if (isProcPtrTarget) {
           // MOLD= procedure pointer
           std::optional<characteristics::Procedure> procPointer;
-          if (IsNullProcedurePointer(*mold)) {
+          if (IsNullProcedurePointer(mold)) {
             procPointer =
                 characteristics::Procedure::Characterize(*mold, context);
           } else {
@@ -2876,20 +2888,23 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
             fResult.emplace(std::move(*procPointer));
           }
         } else if (auto type{mold->GetType()}) {
-          // MOLD= object pointer
+          // MOLD= object pointer or allocatable
           characteristics::TypeAndShape typeAndShape{
               *type, GetShape(context, *mold)};
           args.emplace_back(
               "mold"s, characteristics::DummyDataObject{typeAndShape});
           fResult.emplace(std::move(typeAndShape));
+          isAllocatableMold = IsAllocatableDesignator(*mold);
         } else {
           context.messages().Say(arguments[0]->sourceLocation(),
               "MOLD= argument to NULL() lacks type"_err_en_US);
         }
         if (fResult) {
           fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
           characteristics::Procedure::Attrs attrs;
-          attrs.set(characteristics::Procedure::Attr::NullPointer);
+          attrs.set(isAllocatableMold
+                  ? characteristics::Procedure::Attr::NullAllocatable
+                  : characteristics::Procedure::Attr::NullPointer);
           characteristics::Procedure chars{
               std::move(*fResult), std::move(args), attrs};
           return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
@@ -3248,7 +3263,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
     const auto &arg{call.arguments[0]};
     if (arg) {
       if (const auto *expr{arg->UnwrapExpr()}) {
-        ok = evaluate::IsAllocatableDesignator(*expr);
+        ok = IsAllocatableDesignator(*expr) || IsNullAllocatable(expr);
       }
     }
     if (!ok) {

flang/lib/Evaluate/shape.cpp

@@ -1173,8 +1173,10 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
       if (call.arguments().size() >= 2) {
         return (*this)(call.arguments()[1]); // MASK=
       }
-    } else if (intrinsic->characteristics.value().attrs.test(characteristics::
-                       Procedure::Attr::NullPointer)) { // NULL(MOLD=)
+    } else if (intrinsic->characteristics.value().attrs.test(
+                   characteristics::Procedure::Attr::NullPointer) ||
+        intrinsic->characteristics.value().attrs.test(
+            characteristics::Procedure::Attr::NullAllocatable)) { // NULL(MOLD=)
       return (*this)(call.arguments());
     } else {
       // TODO: shapes of other non-elemental intrinsic results

flang/lib/Evaluate/tools.cpp

@@ -929,7 +929,7 @@ bool IsPointer(const Expr<SomeType> &expr) {
 }
 
 bool IsProcedurePointer(const Expr<SomeType> &expr) {
-  if (IsNullProcedurePointer(expr)) {
+  if (IsNullProcedurePointer(&expr)) {
     return true;
   } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
     if (const Symbol * proc{funcRef->proc().GetSymbol()}) {
@@ -963,7 +963,7 @@ bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
 }
 
 bool IsObjectPointer(const Expr<SomeType> &expr) {
-  if (IsNullObjectPointer(expr)) {
+  if (IsNullObjectPointer(&expr)) {
     return true;
   } else if (IsProcedurePointerTarget(expr)) {
     return false;
@@ -1030,22 +1030,46 @@ template <bool IS_PROC_PTR> struct IsNullPointerHelper {
   }
 };
 
-bool IsNullObjectPointer(const Expr<SomeType> &expr) {
-  return IsNullPointerHelper<false>{}(expr);
+bool IsNullObjectPointer(const Expr<SomeType> *expr) {
+  return expr && IsNullPointerHelper<false>{}(*expr);
 }
 
-bool IsNullProcedurePointer(const Expr<SomeType> &expr) {
-  return IsNullPointerHelper<true>{}(expr);
+bool IsNullProcedurePointer(const Expr<SomeType> *expr) {
+  return expr && IsNullPointerHelper<true>{}(*expr);
 }
 
-bool IsNullPointer(const Expr<SomeType> &expr) {
+bool IsNullPointer(const Expr<SomeType> *expr) {
   return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);
 }
 
 bool IsBareNullPointer(const Expr<SomeType> *expr) {
   return expr && std::holds_alternative<NullPointer>(expr->u);
 }
 
+struct IsNullAllocatableHelper {
+  template <typename A> bool operator()(const A &) const { return false; }
+  template <typename T> bool operator()(const FunctionRef<T> &call) const {
+    const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
+    return intrinsic &&
+        intrinsic->characteristics.value().attrs.test(
+            characteristics::Procedure::Attr::NullAllocatable);
+  }
+  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 IsNullAllocatable(const Expr<SomeType> *x) {
+  return x && IsNullAllocatableHelper{}(*x);
+}
+
+bool IsNullPointerOrAllocatable(const Expr<SomeType> *x) {
+  return IsNullPointer(x) || IsNullAllocatable(x);
+}
+
 // GetSymbolVector()
 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {

flang/lib/Lower/ConvertConstant.cpp

@@ -370,7 +370,7 @@ static mlir::Value genStructureComponentInit(
       /*typeParams=*/mlir::ValueRange{} /*TODO*/);
 
   if (Fortran::semantics::IsAllocatable(sym)) {
-    if (!Fortran::evaluate::IsNullPointer(expr)) {
+    if (!Fortran::evaluate::IsNullPointerOrAllocatable(&expr)) {
       fir::emitFatalError(loc, "constant structure constructor with an "
                                "allocatable component value that is not NULL");
     } else {
@@ -414,7 +414,7 @@ static mlir::Value genStructureComponentInit(
   // must fall through to genConstantValue() below.
   if (Fortran::semantics::IsBuiltinCPtr(sym) && sym.Rank() == 0 &&
       (Fortran::evaluate::GetLastSymbol(expr) ||
-       Fortran::evaluate::IsNullPointer(expr))) {
+       Fortran::evaluate::IsNullPointer(&expr))) {
     // Builtin c_ptr and c_funptr have special handling because designators
     // and NULL() are handled as initial values for them as an extension
     // (otherwise only c_ptr_null/c_funptr_null are allowed and these are