[flang] Disallow NULL() as an expression where it cannot appear

[klausler]

Summary

A NULL() pointer is generally not a valid expression (as opposed to
a variable) apart from some initialization contexts and some actual
arguments.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Semantics/expression.h

public:
   // Manage a set of active implied DO loops.
   bool AddImpliedDo(parser::CharBlock, int kind);
   void RemoveImpliedDo(parser::CharBlock);
 
   // When the argument is the name of an active implied DO index, returns
   // its INTEGER kind type parameter.
   std::optional<int> IsImpliedDo(parser::CharBlock) const;
 
-  // Allows a whole assumed-size array to appear for the lifetime of
-  // the returned value.
-  common::Restorer<bool> AllowWholeAssumedSizeArray() {
-    return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
-  }
-
   common::Restorer<bool> DoNotUseSavedTypedExprs() {
     return common::ScopedSet(useSavedTypedExprs_, false);
   }
 
   Expr<SubscriptInteger> AnalyzeKindSelector(common::TypeCategory category,
       const std::optional<parser::KindSelector> &);
 
   MaybeExpr Analyze(const parser::Expr &);
public:
 
   // Builds a typed Designator from an untyped DataRef
   MaybeExpr Designate(DataRef &&);
 
 protected:
   int IntegerTypeSpecKind(const parser::IntegerTypeSpec &);
 
 private:
+  // Allows a whole assumed-size array to appear for the lifetime of
+  // the returned value.
+  common::Restorer<bool> AllowWholeAssumedSizeArray() {
+    return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
+  }
+
+  // Allows an Expr to be a null pointer.
+  common::Restorer<bool> AllowNullPointer() {
+    return common::ScopedSet(isNullPointerOk_, true);
+  }
+
   MaybeExpr Analyze(const parser::IntLiteralConstant &, bool negated = false);
   MaybeExpr Analyze(const parser::RealLiteralConstant &);
   MaybeExpr Analyze(const parser::ComplexPart &);
   MaybeExpr Analyze(const parser::ComplexLiteralConstant &);
   MaybeExpr Analyze(const parser::LogicalLiteralConstant &);
   MaybeExpr Analyze(const parser::CharLiteralConstant &);
   MaybeExpr Analyze(const parser::HollerithLiteralConstant &);
   MaybeExpr Analyze(const parser::BOZLiteralConstant &);
private:
   }
   bool CheckIsValidForwardReference(const semantics::DerivedTypeSpec &);
   MaybeExpr AnalyzeComplex(MaybeExpr &&re, MaybeExpr &&im, const char *what);
 
   semantics::SemanticsContext &context_;
   FoldingContext &foldingContext_{context_.foldingContext()};
   std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
   bool isWholeAssumedSizeArrayOk_{false};
+  bool isNullPointerOk_{false};
   bool useSavedTypedExprs_{true};
   bool inWhereBody_{false};
   bool inDataStmtConstant_{false};
   friend class ArgumentAnalyzer;
 };
 
 inline bool AreConformable(int leftRank, int rightRank) {
   return leftRank == 0 || rightRank == 0 || leftRank == rightRank;

flang/lib/Semantics/expression.cpp

if (IsConstantExpr(folded)) {
       return folded;
     }
     Say(n.v.source, "must be a constant"_err_en_US); // C718
   }
   return std::nullopt;
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::NullInit &n) {
-  if (MaybeExpr value{Analyze(n.v)}) {
+  auto restorer{AllowNullPointer()};
+  if (MaybeExpr value{Analyze(n.v.value())}) {
     // Subtle: when the NullInit is a DataStmtConstant, it might
     // be a misparse of a structure constructor without parameters
     // or components (e.g., T()).  Checking the result to ensure
     // that a "=>" data entity initializer actually resolved to
     // a null pointer has to be done by the caller.
     return Fold(std::move(*value));
   }
   return std::nullopt;
MaybeExpr ExpressionAnalyzer::Analyze(
   auto nextAnonymous{components.begin()};
 
   std::set<parser::CharBlock> unavailable;
   bool anyKeyword{false};
   StructureConstructor result{spec};
   bool checkConflicts{true}; // until we hit one
   auto &messages{GetContextualMessages()};
 
+  // NULL() can be a valid component
+  auto restorer{AllowNullPointer()};
+
   for (const auto &component :
       std::get<std::list<parser::ComponentSpec>>(structure.t)) {
     const parser::Expr &expr{
         std::get<parser::ComponentDataSource>(component.t).v.value()};
     parser::CharBlock source{expr.source};
     auto restorer{messages.SetLocation(source)};
     const Symbol *symbol{nullptr};
     MaybeExpr value{Analyze(expr)};
if (symbol) {
               "nor a data object"_err_en_US,
               symbol->name());
           continue;
         }
         if (IsPointer(*symbol)) {
           semantics::CheckStructConstructorPointerComponent(
               GetFoldingContext(), *symbol, *value, innermost); // C7104, C7105
           result.Add(*symbol, Fold(std::move(*value)));
-        } else if (MaybeExpr converted{
-                       ConvertToType(*symbol, std::move(*value))}) {
+          continue;
+        }
+        if (IsNullPointer(*value)) {
+          if (IsAllocatable(*symbol)) {
+            if (IsBareNullPointer(&*value)) {
+              // NULL() with no arguments allowed by 7.5.10 para 6 for
+              // ALLOCATABLE.
+              result.Add(*symbol, Expr<SomeType>{NullPointer{}});
+              continue;
+            }
+            if (IsNullObjectPointer(*value)) {
+              AttachDeclaration(
+                  Say(expr.source,
+                      "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
+                      symbol->name()),
+                  *symbol);
+              // proceed to check type & shape
+            } else {
+              AttachDeclaration(
+                  Say(expr.source,
+                      "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,
+                      symbol->name()),
+                  *symbol);
+              continue;
+            }
+          } else {
+            AttachDeclaration(
+                Say(expr.source,
+                    "A NULL pointer may not be used as the value for component '%s'"_err_en_US,
+                    symbol->name()),
+                *symbol);
+            continue;
+          }
+        }
+        if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) {
           if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
             if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
               if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
                 AttachDeclaration(
                     Say(expr.source,
                         "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
                         GetRank(*valueShape), symbol->name()),
                     *symbol);
if (symbol) {
             }
           } else {
             AttachDeclaration(
                 Say(expr.source,
                     "Shape of component '%s' cannot be determined"_err_en_US,
                     symbol->name()),
                 *symbol);
           }
-        } else if (IsAllocatable(*symbol) && IsBareNullPointer(&*value)) {
-          // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE.
-          result.Add(*symbol, Expr<SomeType>{NullPointer{}});
         } else if (auto symType{DynamicType::From(symbol)}) {
           if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
               valueType) {
             // ok
           } else if (valueType) {
             AttachDeclaration(
                 Say(expr.source,
                     "Value in structure constructor of type '%s' is "
const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
   }
   return common::GetPtrFromOptional(x.typedAssignment->v);
 }
 
 const Assignment *ExpressionAnalyzer::Analyze(
     const parser::PointerAssignmentStmt &x) {
   if (!x.typedAssignment) {
     MaybeExpr lhs{Analyze(std::get<parser::DataRef>(x.t))};
-    MaybeExpr rhs{Analyze(std::get<parser::Expr>(x.t))};
+    MaybeExpr rhs;
+    {
+      auto restorer{AllowNullPointer()};
+      rhs = Analyze(std::get<parser::Expr>(x.t));
+    }
     if (!lhs || !rhs) {
       x.typedAssignment.Reset(
           new GenericAssignmentWrapper{}, GenericAssignmentWrapper::Deleter);
     } else {
       Assignment assignment{std::move(*lhs), std::move(*rhs)};
       common::visit(
           common::visitors{
               [&](const std::list<parser::BoundsRemapping> &list) {
static void FixMisparsedFunctionReference(
   }
 }
 
 // Common handling of parse tree node types that retain the
 // representation of the analyzed expression.
 template <typename PARSED>
 MaybeExpr ExpressionAnalyzer::ExprOrVariable(
     const PARSED &x, parser::CharBlock source) {
-  if (useSavedTypedExprs_ && x.typedExpr) {
-    return x.typedExpr->v;
-  }
   auto restorer{GetContextualMessages().SetLocation(source)};
   if constexpr (std::is_same_v<PARSED, parser::Expr> ||
       std::is_same_v<PARSED, parser::Variable>) {
     FixMisparsedFunctionReference(context_, x.u);
   }
   if (AssumedTypeDummy(x)) { // C710
     Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
     ResetExpr(x);
if (!context_.AnyFatalError()) {
       Say("Internal error: Expression analysis failed on: %s"_err_en_US,
           dump.str());
     }
     return std::nullopt;
   }
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
-  return ExprOrVariable(expr, expr.source);
+  if (useSavedTypedExprs_ && expr.typedExpr) {
+    return expr.typedExpr->v;
+  }
+  MaybeExpr result{ExprOrVariable(expr, expr.source)};
+  if (!isNullPointerOk_ && result && IsNullPointer(*result)) {
+    Say(expr.source,
+        "NULL() may not be used as an expression in this context"_err_en_US);
+  }
+  return result;
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Variable &variable) {
+  if (useSavedTypedExprs_ && variable.typedExpr) {
+    return variable.typedExpr->v;
+  }
   return ExprOrVariable(variable, variable.GetSource());
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Selector &selector) {
   if (const auto *var{std::get_if<parser::Variable>(&selector.u)}) {
     if (!useSavedTypedExprs_ || !var->typedExpr) {
       parser::CharBlock source{var->GetSource()};
       auto restorer{GetContextualMessages().SetLocation(source)};
if (!symbol) {
           x, "Assignment to '%s' is not allowed"_err_en_US, symbol->name());
     }
   }
   fatalErrors_ = true;
 }
 
 void ArgumentAnalyzer::Analyze(
     const parser::ActualArgSpec &arg, bool isSubroutine) {
-  // TODO: Actual arguments that are procedures and procedure pointers need to
-  // be detected and represented (they're not expressions).
   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
   std::optional<ActualArgument> actual;
   common::visit(common::visitors{
                     [&](const common::Indirection<parser::Expr> &x) {
                       actual = AnalyzeExpr(x.value());
                       SetArgSourceLocation(actual, x.value().source);
                     },
                     [&](const parser::AltReturnSpec &label) {
MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
   // treat it as a special case for argument passing and bypass
   // the C1002/C1014 constraint checking in expression semantics.
   if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
     if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
       auto restorer{context_.AllowWholeAssumedSizeArray()};
       return context_.Analyze(expr);
     }
   }
+  auto restorer{context_.AllowNullPointer()};
   return context_.Analyze(expr);
 }
 
 bool ArgumentAnalyzer::AreConformable() const {
   CHECK(actuals_.size() == 2);
   return actuals_[0] && actuals_[1] &&
       evaluate::AreConformable(*actuals_[0], *actuals_[1]);
 }

flang/lib/Semantics/resolve-names.cpp

bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
   return true;
 }
 void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) {
   interfaceName_ = nullptr;
 }
 bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
   if (auto *name{std::get_if<parser::Name>(&x.u)}) {
     return !NameIsKnownOrIntrinsic(*name) && !CheckUseError(*name);
+  } else {
+    const auto &null{DEREF(std::get_if<parser::NullInit>(&x.u))};
+    Walk(null);
+    if (auto nullInit{EvaluateExpr(null)}) {
+      if (!evaluate::IsNullPointer(*nullInit)) {
+        Say(null.v.value().source,
+            "Procedure pointer initializer must be a name or intrinsic NULL()"_err_en_US);
+      }
+    }
+    return false;
   }
-  return true;
 }
 void DeclarationVisitor::Post(const parser::ProcInterface &x) {
   if (auto *name{std::get_if<parser::Name>(&x.u)}) {
     interfaceName_ = name;
     NoteInterfaceName(*name);
   }
 }
 void DeclarationVisitor::Post(const parser::ProcDecl &x) {
void DeclarationVisitor::Initialization(const parser::Name &name,
   common::visit(
       common::visitors{
           [&](const parser::ConstantExpr &expr) {
             NonPointerInitialization(name, expr);
           },
           [&](const parser::NullInit &null) { // => NULL()
             Walk(null);
             if (auto nullInit{EvaluateExpr(null)}) {
-              if (!evaluate::IsNullPointer(*nullInit)) {
-                Say(name,
-                    "Pointer initializer must be intrinsic NULL()"_err_en_US); // C813
+              if (!evaluate::IsNullPointer(*nullInit)) { // C813
+                Say(null.v.value().source,
+                    "Pointer initializer must be intrinsic NULL()"_err_en_US);
               } else if (IsPointer(ultimate)) {
                 if (auto *object{ultimate.detailsIf<ObjectEntityDetails>()}) {
                   object->set_init(std::move(*nullInit));
                 } else if (auto *procPtr{
                                ultimate.detailsIf<ProcEntityDetails>()}) {
                   procPtr->set_init(nullptr);
                 }
               } else {

 void DeclarationVisitor::PointerInitialization(
     const parser::Name &name, const parser::ProcPointerInit &target) {
   if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
     if (!context().HasError(ultimate)) {
       if (IsProcedurePointer(ultimate)) {
         auto &details{ultimate.get<ProcEntityDetails>()};
         CHECK(!details.init());
-        Walk(target);
         if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) {
+          Walk(target);
           if (!CheckUseError(*targetName) && targetName->symbol) {
             // Validation is done in declaration checking.
             details.set_init(*targetName->symbol);
           }
-        } else {
-          details.set_init(nullptr); // explicit NULL()
+        } else { // explicit NULL
+          details.set_init(nullptr);
         }
       } else {
         Say(name,
             "'%s' is not a procedure pointer but is initialized "
             "like one"_err_en_US);
         context().SetError(ultimate);
       }
     }

flang/test/Semantics/null01.f90

interface
     function f3()
       import s1
       procedure(s1), pointer :: f3
     end function
   end interface
   external implicit
   type :: dt0
     integer, pointer :: ip0
+    integer :: n = 666
   end type dt0
   type :: dt1
     integer, pointer :: ip1(:)
   end type dt1
   type :: dt2
     procedure(s0), pointer, nopass :: pps0
   end type dt2
   type :: dt3
     procedure(s1), pointer, nopass :: pps1
   end type dt3
+  type :: dt4
+    real, allocatable :: ra0
+  end type dt4
   integer :: j
   type(dt0) :: dt0x
   type(dt1) :: dt1x
   type(dt2) :: dt2x
   type(dt3) :: dt3x
+  type(dt4) :: dt4x
   integer, pointer :: ip0, ip1(:), ip2(:,:)
   integer, allocatable :: ia0, ia1(:), ia2(:,:)
   real, pointer :: rp0, rp1(:)
   integer, parameter :: ip0r = rank(null(mold=ip0))
   integer, parameter :: ip1r = rank(null(mold=ip1))
   integer, parameter :: ip2r = rank(null(mold=ip2))
   integer, parameter :: eight = ip0r + ip1r + ip2r + 5
   real(kind=eight) :: r8check
+  logical, pointer :: lp
   ip0 => null() ! ok
   ip1 => null() ! ok
   ip2 => null() ! ok
   !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
   ip0 => null(mold=1)
   !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
   ip0 => null(mold=j)
   dt0x = dt0(null())
   dt0x = dt0(ip0=null())
   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)'
   dt0x = dt0(ip0=null(mold=rp0))
+  !ERROR: A NULL pointer may not be used as the value for component 'n'
+  dt0x = dt0(null(), null())
   !ERROR: function result type 'REAL(4)' is not compatible with pointer type 'INTEGER(4)'
   dt1x = dt1(ip1=null(mold=rp1))
   dt2x = dt2(pps0=null())
   dt2x = dt2(pps0=null(mold=dt2x%pps0))
   !ERROR: Procedure pointer 'pps0' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
   dt2x = dt2(pps0=null(mold=dt3x%pps1))
   !ERROR: Procedure pointer 'pps1' associated with result of reference to function 'null' that is an incompatible procedure pointer: distinct numbers of dummy arguments
   dt3x = dt3(pps1=null(mold=dt2x%pps0))
   dt3x = dt3(pps1=null(mold=dt3x%pps1))
+  dt4x = dt4(null()) ! ok
+  !PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'ra0'
+  dt4x = dt4(null(rp0))
+  !PORTABILITY: NULL() with arguments is not standard conforming as the value for allocatable component 'ra0'
+  !ERROR: Rank-1 array value is not compatible with scalar component 'ra0'
+  dt4x = dt4(null(rp1))
+  !ERROR: A NULL procedure pointer may not be used as the value for component 'ra0'
+  dt4x = dt4(null(dt2x%pps0))
   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))
   !ERROR: A NULL() pointer is not allowed for 'x=' intrinsic argument
   print *, sin(null(rp0))
   !ERROR: A NULL() pointer is not allowed for 'source=' intrinsic argument
   print *, transfer(null(rp0),ip0)
+  !ERROR: NULL() may not be used as an expression in this context
+  select case(null(ip0))
+  end select
+  !ERROR: NULL() may not be used as an expression in this context
+  if (null(lp)) then
+  end if
 end subroutine test