[flang] Fix source provenance of .NOT., add ALLOCATED intrinsic

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

diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc
index 25c98f4..a7675b6 100644 (file)
--- a/flang/lib/evaluate/intrinsics.cc
+++ b/flang/lib/evaluate/intrinsics.cc
@@ -245,6 +245,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
     {"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
         Rank::dimReduced},
+    {"allocated", {{"array", Anything, Rank::array}}, DefaultLogical},
+    {"allocated", {{"scalar", Anything, Rank::scalar}}, DefaultLogical},
     {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
     {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
         Rank::dimReduced},
@@ -618,7 +620,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 //   NUM_IMAGES, STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE,
 //   COSHAPE
 // TODO: Object characteristic inquiry functions
-//   ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS,
+//   ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS,
 //   SAME_TYPE, STORAGE_SIZE
 // TODO: Type inquiry intrinsic functions - these return constants
 //  BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT,
@@ -1384,6 +1386,40 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
       std::move(arguments)};
 }
 
+// Applies any semantic checks peculiar to an intrinsic.
+static bool ApplySpecificChecks(
+    SpecificCall &call, parser::ContextualMessages &messages) {
+  bool ok{true};
+  const std::string &name{call.specificIntrinsic.name};
+  if (name == "allocated") {
+    if (const auto &arg{call.arguments[0]}) {
+      if (const auto *expr{arg->UnwrapExpr()}) {
+        if (const Symbol * symbol{GetLastSymbol(*expr)}) {
+          ok = symbol->has<semantics::ObjectEntityDetails>() &&
+              symbol->attrs().test(semantics::Attr::ALLOCATABLE);
+        }
+      }
+    }
+    if (!ok) {
+      messages.Say(
+          "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
+    }
+  } else if (name == "present") {
+    if (const auto &arg{call.arguments[0]}) {
+      if (const auto *expr{arg->UnwrapExpr()}) {
+        if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) {
+          ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
+        }
+      }
+    }
+    if (!ok) {
+      messages.Say(
+          "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
+    }
+  }
+  return ok;
+};
+
 // Probe the configured intrinsic procedure pattern tables in search of a
 // match for a given procedure reference.
 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
@@ -1417,21 +1453,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     CHECK(localBuffer.empty());
     if (auto specificCall{
             iter->second->Match(call, defaults_, arguments, localContext)}) {
-      // Apply any semantic checks peculiar to the intrinsic
-      if (call.name == "present") {
-        bool ok{false};
-        if (const auto &arg{specificCall->arguments[0]}) {
-          if (const auto *expr{arg->UnwrapExpr()}) {
-            if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) {
-              ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
-            }
-          }
-        }
-        if (!ok) {
-          localMessages.Say(
-              "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
-        }
-      }
+      ApplySpecificChecks(*specificCall, localMessages);
       if (finalBuffer != nullptr) {
         finalBuffer->Annex(std::move(localBuffer));
       }

diff --git a/flang/lib/parser/grammar.h b/flang/lib/parser/grammar.h
index 7a35e92..a3d00db 100644 (file)
--- a/flang/lib/parser/grammar.h
+++ b/flang/lib/parser/grammar.h
@@ -1799,18 +1799,12 @@ constexpr struct AndOperand {
 } andOperand;
 
 inline std::optional<Expr> AndOperand::Parse(ParseState &state) {
-  static constexpr auto op{attempt(".NOT."_tok)};
-  int complements{0};
-  while (op.Parse(state)) {
-    ++complements;
+  static constexpr auto notOp{attempt(".NOT."_tok >> andOperand)};
+  if (std::optional<Expr> negation{notOp.Parse(state)}) {
+    return Expr{Expr::NOT{std::move(*negation)}};
+  } else {
+    return level4Expr.Parse(state);
   }
-  std::optional<Expr> result{level4Expr.Parse(state)};
-  if (result.has_value()) {
-    while (complements-- > 0) {
-      result = Expr{Expr::NOT{std::move(*result)}};
-    }
-  }
-  return result;
 }
 
 // R1015 or-operand -> [or-operand and-op] and-operand
@@ -1820,7 +1814,8 @@ constexpr struct OrOperand {
   using resultType = Expr;
   constexpr OrOperand() {}
   static inline std::optional<Expr> Parse(ParseState &state) {
-    std::optional<Expr> result{andOperand.Parse(state)};
+    static constexpr auto operand{sourced(andOperand)};
+    std::optional<Expr> result{operand.Parse(state)};
     if (result) {
       auto source{result->source};
       std::function<Expr(Expr &&)> logicalAnd{[&result](Expr &&right) {

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index d5e76ed..7d97d21 100644 (file)
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -1613,8 +1613,6 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
               return {AsGenericExpr(LogicalNegation(std::move(lx)))};
             },
             [&](auto &&) -> MaybeExpr {
-              // TODO: accept INTEGER operand and maybe typeless
-              // if not overridden
               Say("Operand of .NOT. must be LOGICAL"_err_en_US);
               return std::nullopt;
             },
@@ -1871,7 +1869,7 @@ MaybeExpr ExpressionAnalyzer::ExprOrVariable(const PARSED &x) {
     if constexpr (std::is_same_v<PARSED, parser::Expr>) {
       // Analyze the expression in a specified source position context for
       // better error reporting.
-      auto save{GetFoldingContext().messages().SetLocation(x.source)};
+      auto save{GetContextualMessages().SetLocation(x.source)};
       result = Analyze(x.u);
     } else {
       result = Analyze(x.u);

diff --git a/flang/lib/semantics/expression.h b/flang/lib/semantics/expression.h
index 1401948..ae7a775 100644 (file)
--- a/flang/lib/semantics/expression.h
+++ b/flang/lib/semantics/expression.h
@@ -185,10 +185,10 @@ public:
     return result;
   }
   template<typename A> MaybeExpr Analyze(const parser::Constant<A> &x) {
+    auto save{
+        GetFoldingContext().messages().SetLocation(FindSourceLocation(x))};
     auto result{Analyze(x.thing)};
     if (result.has_value()) {
-      auto save{
-          GetFoldingContext().messages().SetLocation(FindSourceLocation(x))};
       *result = Fold(GetFoldingContext(), std::move(*result));
       if (!IsConstantExpr(*result)) {
         SayAt(x, "Must be a constant value"_err_en_US);

diff --git a/flang/test/semantics/test_modfile.sh b/flang/test/semantics/test_modfile.sh
index f6e737f..3c09b64 100755 (executable)
--- a/flang/test/semantics/test_modfile.sh
+++ b/flang/test/semantics/test_modfile.sh
@@ -60,7 +60,7 @@ for src in "$@"; do
       exit 1
     fi
     # The first three bytes of the file are a UTF-8 BOM
-    sed '/^.!mod\$/d' $temp/$mod > $actual
+    sed '/^[^!]*!mod\$/d' $temp/$mod > $actual
     sed '1,/^!Expect: '"$mod"'/d' $src | sed -e '/^$/,$d' -e 's/^! *//' > $expect
     if ! diff -U999999 $expect $actual > $diffs; then
       echo "Module file $mod differs from expected:"