[flang] Correct checking of PRESENT()

[klausler]

The argument to the PRESENT() intrinsic function must be the name of a a whole OPTIONAL dummy argument.

Fixes llvm-test-suite/Fortran/gfortran/regression/present_1.f90.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

The argument to the PRESENT() intrinsic function must be the name of a a whole OPTIONAL dummy argument.

Fixes llvm-test-suite/Fortran/gfortran/regression/present_1.f90.

---

Full diff: https://github.com/llvm/llvm-project/pull/78364.diff

3 Files Affected:

• (modified) flang/lib/Evaluate/intrinsics.cpp (-16)
• (modified) flang/lib/Semantics/check-call.cpp (+26)
• (added) flang/test/Semantics/present01.f90 (+21)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index da6d5970089884..e1435d3678a46d 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2881,8 +2881,6 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
-  } else if (name == "associated" || name == "reduce") {
-    // Now handled in Semantics/check-call.cpp
   } else if (name == "atomic_and" || name == "atomic_or" ||
       name == "atomic_xor") {
     return CheckForCoindexedObject(
@@ -2924,20 +2922,6 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of LOC() must be an object or procedure"_err_en_US);
     }
-  } else if (name == "present") {
-    const auto &arg{call.arguments[0]};
-    if (arg) {
-      if (const auto *expr{arg->UnwrapExpr()}) {
-        if (const Symbol *symbol{UnwrapWholeSymbolDataRef(*expr)}) {
-          ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
-        }
-      }
-    }
-    if (!ok) {
-      context.messages().Say(
-          arg ? arg->sourceLocation() : context.messages().at(),
-          "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
-    }
   } else if (name == "ucobound") {
     return CheckDimAgainstCorank(call, context);
   }
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index a8927e94481d4b..d770c94b603f19 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1468,6 +1468,30 @@ static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
   }
 }
 
+// PRESENT (F'2023 16.9.163)
+static void CheckPresent(evaluate::ActualArguments &arguments,
+    parser::ContextualMessages &messages) {
+  if (arguments.size() == 1) {
+    if (const auto &arg{arguments[0]}; arg) {
+      const Symbol *symbol{nullptr};
+      if (const auto *expr{arg->UnwrapExpr()}) {
+        if (const auto *proc{
+                std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
+          symbol = proc->GetSymbol();
+        } else {
+          symbol = evaluate::UnwrapWholeSymbolDataRef(*expr);
+        }
+      } else {
+        symbol = arg->GetAssumedTypeDummy();
+      }
+      if (!symbol || !symbol->attrs().test(semantics::Attr::OPTIONAL)) {
+        messages.Say(arg ? arg->sourceLocation() : messages.at(),
+            "Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US);
+      }
+    }
+  }
+}
+
 // REDUCE (F'2023 16.9.173)
 static void CheckReduce(
     evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
@@ -1678,6 +1702,8 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
     CheckAssociated(arguments, context, scope);
   } else if (intrinsic.name == "move_alloc") {
     CheckMove_Alloc(arguments, context.foldingContext().messages());
+  } else if (intrinsic.name == "present") {
+    CheckPresent(arguments, context.foldingContext().messages());
   } else if (intrinsic.name == "reduce") {
     CheckReduce(arguments, context.foldingContext());
   } else if (intrinsic.name == "transfer") {
diff --git a/flang/test/Semantics/present01.f90 b/flang/test/Semantics/present01.f90
new file mode 100644
index 00000000000000..5b0233931ac97d
--- /dev/null
+++ b/flang/test/Semantics/present01.f90
@@ -0,0 +1,21 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type dt
+    real a
+  end type
+ contains
+  subroutine s(a,b,p,unl)
+    type(dt), optional :: a(:), b
+    procedure(sin), optional :: p
+    type(*), optional :: unl
+    print *, present(a) ! ok
+    print *, present(p) ! ok
+    print *, present(unl) ! ok
+    !ERROR: Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument
+    print *, present(a(1))
+    !ERROR: Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument
+    print *, present(b%a)
+    !ERROR: Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument
+    print *, present(a(1)%a)
+  end
+end

[clementval]

LGTM