[flang] Represent NULL()

Original-commit: flang-compiler/f18@2c3368fb5f
Reviewed-on: https://github.com/flang-compiler/f18/pull/311
Tree-same-pre-rewrite: false

flang/lib/evaluate/expression.cc

@@ -146,6 +146,7 @@ std::ostream &ExpressionBase<RESULT>::AsFortran(std::ostream &o) const {
           [&](const BOZLiteralConstant &x) {
             o << "z'" << x.Hexadecimal() << "'";
           },
+          [&](const NullPointer &) { o << "NULL()"; },
           [&](const CopyableIndirection<Substring> &s) { s->AsFortran(o); },
           [&](const ImpliedDoIndex &i) { o << i.name.ToString(); },
           [&](const auto &x) { x.AsFortran(o); },
@@ -201,11 +202,13 @@ std::optional<DynamicType> ExpressionBase<A>::GetType() const {
   } else {
     return std::visit(
         [](const auto &x) -> std::optional<DynamicType> {
-          if constexpr (!std::is_same_v<std::decay_t<decltype(x)>,
-                            BOZLiteralConstant>) {
+          using Ty = std::decay_t<decltype(x)>;
+          if constexpr (std::is_same_v<Ty, BOZLiteralConstant> ||
+              std::is_same_v<Ty, NullPointer>) {
+            return std::nullopt;  // typeless really means "no type"
+          } else {
             return x.GetType();
           }
-          return std::nullopt;  // typeless really means "no type"
         },
         derived().u);
   }

flang/lib/evaluate/expression.h

@@ -98,12 +98,6 @@ public:
   static Derived Rewrite(FoldingContext &, Derived &&);
 };
 
-// BOZ literal "typeless" constants must be wide enough to hold a numeric
-// value of any supported kind of INTEGER or REAL.  They must also be
-// distinguishable from other integer constants, since they are permitted
-// to be used in only a few situations.
-using BOZLiteralConstant = typename LargestReal::Scalar::Word;
-
 // Operations always have specific Fortran result types (i.e., with known
 // intrinsic type category and kind parameter value).  The classes that
 // represent the operations all inherit from this Operation<> base class
@@ -725,6 +719,18 @@ public:
   common::MapTemplate<Expr, CategoryTypes<CAT>> u;
 };
 
+// BOZ literal "typeless" constants must be wide enough to hold a numeric
+// value of any supported kind of INTEGER or REAL.  They must also be
+// distinguishable from other integer constants, since they are permitted
+// to be used in only a few situations.
+using BOZLiteralConstant = typename LargestReal::Scalar::Word;
+
+// Null pointers without MOLD= arguments are typed by context.
+struct NullPointer {
+  constexpr bool operator==(const NullPointer &) const { return true; }
+  constexpr int Rank() const { return 0; }
+};
+
 // A completely generic expression, polymorphic across all of the intrinsic type
 // categories and each of their kinds.
 template<> class Expr<SomeType> : public ExpressionBase<SomeType> {
@@ -757,7 +763,7 @@ public:
   }
 
 private:
-  using Others = std::variant<BOZLiteralConstant>;
+  using Others = std::variant<BOZLiteralConstant, NullPointer>;
   using Categories = common::MapTemplate<Expr, SomeCategory>;
 
 public:

flang/lib/evaluate/fold.cc

@@ -759,11 +759,14 @@ Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
           return FoldOperation(context, std::move(x));
         } else if constexpr (std::is_same_v<T, SomeDerived>) {
           return FoldOperation(context, std::move(x));
-        } else if constexpr (std::is_same_v<BOZLiteralConstant,
-                                 std::decay_t<decltype(x)>>) {
-          return std::move(expr);
         } else {
-          return Expr<T>{Fold(context, std::move(x))};
+          using Ty = std::decay_t<decltype(x)>;
+          if constexpr (std::is_same_v<Ty, BOZLiteralConstant> ||
+              std::is_same_v<Ty, NullPointer>) {
+            return std::move(expr);
+          } else {
+            return Expr<T>{Fold(context, std::move(x))};
+          }
         }
       },
       std::move(expr.u));
@@ -789,6 +792,7 @@ struct ConstExprContext {
 bool IsConstExpr(ConstExprContext &, const BOZLiteralConstant &) {
   return true;
 }
+bool IsConstExpr(ConstExprContext &, const NullPointer &) { return true; }
 template<typename A> bool IsConstExpr(ConstExprContext &, const Constant<A> &) {
   return true;
 }

flang/lib/evaluate/intrinsics.cc

@@ -1163,9 +1163,9 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     }
   }
 
-  return {SpecificCall{
+  return std::make_optional<SpecificCall>(
       SpecificIntrinsic{name, std::move(resultType), resultRank, attrs},
-      std::move(rearranged)}};
+      std::move(rearranged));
 }
 
 class IntrinsicProcTable::Implementation {
@@ -1254,9 +1254,9 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
   // Special cases of intrinsic functions
   if (call.name.ToString() == "null") {
     if (arguments.size() == 0) {
-      // TODO: NULL() result type is determined by context
-      // Can pass that context in, or return a token distinguishing
-      // NULL, or represent NULL as a new kind of top-level expression
+      return std::make_optional<SpecificCall>(
+          SpecificIntrinsic{"null"s}, std::move(arguments));
+      // TODO pmk work in progress - fold into NullPointer (where?)
     } else if (arguments.size() > 1) {
       genericErrors.Say("too many arguments to NULL()"_err_en_US);
     } else if (arguments[0].has_value() && arguments[0]->keyword.has_value() &&
@@ -1264,10 +1264,16 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
       genericErrors.Say("unknown argument '%s' to NULL()"_err_en_US,
           arguments[0]->keyword->ToString().data());
     } else {
-      // TODO: Argument must be pointer, procedure pointer, or allocatable.
-      // Characteristics, including dynamic length type parameter values,
-      // must be taken from the MOLD argument.
-      // TODO: set Attr::POINTER on NULL result
+      Expr<SomeType> &mold{*arguments[0]->value};
+      if (IsPointerOrAllocatable(mold)) {
+        return std::make_optional<SpecificCall>(
+            SpecificIntrinsic{"null"s, mold.GetType(), mold.Rank(),
+                semantics::Attrs{semantics::Attr::POINTER}},
+            std::move(arguments));
+      } else {
+        genericErrors.Say("MOLD argument to NULL() must be a pointer "
+                          "or allocatable"_err_en_US);
+      }
     }
   }
   // No match

flang/lib/evaluate/tools.cc

@@ -347,6 +347,10 @@ std::optional<Expr<SomeType>> Negation(
             messages.Say("BOZ literal cannot be negated"_err_en_US);
             return NoExpr();
           },
+          [&](NullPointer &&) {
+            messages.Say("NULL() cannot be negated"_err_en_US);
+            return NoExpr();
+          },
           [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
           [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
           [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
@@ -501,7 +505,8 @@ std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
   return std::visit(
       [=](auto &&cx) -> std::optional<Expr<SomeType>> {
         using cxType = std::decay_t<decltype(cx)>;
-        if constexpr (!std::is_same_v<cxType, BOZLiteralConstant>) {
+        if constexpr (!std::is_same_v<cxType, BOZLiteralConstant> &&
+            !std::is_same_v<cxType, NullPointer>) {
           if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
             return std::make_optional(
                 Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))});

flang/lib/evaluate/tools.h

@@ -20,6 +20,7 @@
 #include "../common/idioms.h"
 #include "../common/unwrap.h"
 #include "../parser/message.h"
+#include "../semantics/attr.h"
 #include "../semantics/symbol.h"
 #include <array>
 #include <optional>
@@ -124,6 +125,10 @@ inline Expr<SomeType> AsGenericExpr(BOZLiteralConstant &&x) {
   return Expr<SomeType>{std::move(x)};
 }
 
+inline Expr<SomeType> AsGenericExpr(NullPointer &&x) {
+  return Expr<SomeType>{std::move(x)};
+}
+
 Expr<SomeReal> GetComplexPart(
     const Expr<SomeComplex> &, bool isImaginary = false);
 
@@ -140,7 +145,8 @@ auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
   using Ty = std::decay_t<B>;
   if constexpr (std::is_same_v<A, Ty>) {
     return &x;
-  } else if constexpr (std::is_same_v<Ty, BOZLiteralConstant>) {
+  } else if constexpr (std::is_same_v<Ty, BOZLiteralConstant> ||
+      std::is_same_v<Ty, NullPointer>) {
     return nullptr;
   } else if constexpr (std::is_same_v<Ty, Expr<ResultType<A>>>) {
     return common::Unwrap<A>(x.u);
@@ -521,5 +527,31 @@ struct TypeKindVisitor {
   int kind;
   VALUE value;
 };
+
+template<typename A> const semantics::Symbol *GetLastSymbol(const A &) {
+  return nullptr;
+}
+
+template<typename T>
+const semantics::Symbol *GetLastSymbol(const Designator<T> &x) {
+  return x.GetLastSymbol();
+}
+
+template<typename T> const semantics::Symbol *GetLastSymbol(const Expr<T> &x) {
+  return std::visit([](const auto &y) { return GetLastSymbol(y); }, x.u);
+}
+
+template<typename A> semantics::Attrs GetAttrs(const A &x) {
+  if (const semantics::Symbol * symbol{GetLastSymbol(x)}) {
+    return symbol->attrs();
+  } else {
+    return {};
+  }
+}
+
+template<typename A> bool IsPointerOrAllocatable(const A &x) {
+  return GetAttrs(x).HasAny(
+      semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
+}
 }
 #endif  // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/semantics/expression.cc

@@ -96,6 +96,7 @@ static std::optional<DataRef> ExtractDataRef(Expr<SomeType> &&expr) {
           [](BOZLiteralConstant &&) -> std::optional<DataRef> {
             return std::nullopt;
           },
+          [](NullPointer &&) -> std::optional<DataRef> { return std::nullopt; },
           [](auto &&catExpr) { return ExtractDataRef(std::move(catExpr)); },
       },
       std::move(expr.u));
@@ -1644,6 +1645,9 @@ static MaybeExpr AnalyzeExpr(
             [&](BOZLiteralConstant &&boz) {
               return operand;  // ignore parentheses around typeless constants
             },
+            [&](NullPointer &&boz) {
+              return operand;  // ignore parentheses around NULL()
+            },
             [&](Expr<SomeDerived> &&) {
               // TODO: parenthesized derived type variable
               return operand;
@@ -1669,6 +1673,9 @@ static MaybeExpr AnalyzeExpr(
     std::visit(
         common::visitors{
             [](const BOZLiteralConstant &) {},  // allow +Z'1', it's harmless
+            [&](const NullPointer &) {
+              context.Say("+NULL() is not allowed"_err_en_US);
+            },
             [&](const auto &catExpr) {
               TypeCategory cat{ResultType<decltype(catExpr)>::category};
               if (cat != TypeCategory::Integer && cat != TypeCategory::Real &&