[flang-commits] [flang] 3bca850 - [flang] Correct checking of PRESENT() (#78364)

[via flang-commits]

Author: Peter Klausler
Date: 2024-01-25T14:20:16-08:00
New Revision: 3bca8506ab65c66e32695ba50571c4384be8e4d1

URL: https://github.com/llvm/llvm-project/commit/3bca8506ab65c66e32695ba50571c4384be8e4d1
DIFF: https://github.com/llvm/llvm-project/commit/3bca8506ab65c66e32695ba50571c4384be8e4d1.diff

LOG: [flang] Correct checking of PRESENT() (#78364)

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.

Added: 
    flang/test/Semantics/present01.f90

Modified: 
    flang/lib/Evaluate/intrinsics.cpp
    flang/lib/Semantics/check-call.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 7d2e45dcbe96ded..e3a9d54136ae9a2 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2896,8 +2896,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(
@@ -2939,20 +2937,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 c924a817ec7e19e..80ec1310a31432a 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1470,6 +1470,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) {
@@ -1680,6 +1704,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 000000000000000..5b0233931ac97d2
--- /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