[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

   // 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);
   }

   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 &);

   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};

flang/lib/Semantics/expression.cpp

 }
 
 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

   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{

           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) {

                     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) {

     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);

 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>) {

 }
 
 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());
 }
 

 
 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{

       return context_.Analyze(expr);
     }
   }
+  auto restorer{context_.AllowNullPointer()};
   return context_.Analyze(expr);
 }
 

flang/lib/Semantics/resolve-names.cpp

 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)}) {

           [&](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));

       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,

flang/test/Semantics/null01.f90

   external implicit
   type :: dt0
     integer, pointer :: ip0
+    integer :: n = 666
   end type dt0
   type :: dt1
     integer, pointer :: ip1(:)

   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 :: 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

   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())

   !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

   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