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

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},
@@ -1892,9 +1896,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 {
@@ -1905,6 +1909,14 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         }
       }
     }
+    if (!d.flags.test(ArgFlag::canBeNullAllocatable) &&
+        IsNullAllocatable(arg->UnwrapExpr()) &&
+        !d.flags.test(ArgFlag::canBeMoldNull)) {
+      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())) {
@@ -2862,14 +2874,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 {
@@ -2885,20 +2898,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)},
@@ -3257,7 +3273,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>()}) {
@@ -1393,7 +1417,7 @@ bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {
   const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
   return (sym &&
              semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
-      evaluate::IsObjectPointer(expr);
+      evaluate::IsObjectPointer(expr) || evaluate::IsNullAllocatable(&expr);
 }
 
 bool IsAllocatableDesignator(const Expr<SomeType> &expr) {

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