[flang-commits] [flang] 303ecc4 - [flang] Add one semantic check for implicit interface

[via flang-commits]

Author: PeixinQiao
Date: 2022-05-01T18:40:17+08:00
New Revision: 303ecc42d42fcefb421ce9890df97e8ae3e1fd60

URL: https://github.com/llvm/llvm-project/commit/303ecc42d42fcefb421ce9890df97e8ae3e1fd60
DIFF: https://github.com/llvm/llvm-project/commit/303ecc42d42fcefb421ce9890df97e8ae3e1fd60.diff

LOG: [flang] Add one semantic check for implicit interface

As Fortran 2018 C1533, a nonintrinsic elemental procedure shall not be
used as an actual argument. The semantic check for implicit iterface is
missed.

Reviewed By: klausler

Differential Revision: https://reviews.llvm.org/D124379

Added: 
    

Modified: 
    flang/lib/Semantics/check-call.cpp
    flang/test/Semantics/call02.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 301f905b58bd2..e2b556ae32dfa 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -24,8 +24,8 @@ namespace characteristics = Fortran::evaluate::characteristics;
 
 namespace Fortran::semantics {
 
-static void CheckImplicitInterfaceArg(
-    evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
+static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
+    parser::ContextualMessages &messages, evaluate::FoldingContext &context) {
   auto restorer{
       messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
   if (auto kw{arg.keyword()}) {
@@ -73,6 +73,18 @@ static void CheckImplicitInterfaceArg(
         messages.Say(
             "VOLATILE argument requires an explicit interface"_err_en_US);
       }
+    } else if (auto argChars{characteristics::DummyArgument::FromActual(
+                   "actual argument", *expr, context)}) {
+      const auto *argProcDesignator{
+          std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
+      const auto *argProcSymbol{
+          argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
+      if (argProcSymbol && !argChars->IsTypelessIntrinsicDummy() &&
+          argProcDesignator && argProcDesignator->IsElemental()) { // C1533
+        evaluate::SayWithDeclaration(messages, *argProcSymbol,
+            "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
+            argProcSymbol->name());
+      }
     }
   }
 }
@@ -877,7 +889,7 @@ void CheckArguments(const characteristics::Procedure &proc,
       auto restorer{messages.SetMessages(buffer)};
       for (auto &actual : actuals) {
         if (actual) {
-          CheckImplicitInterfaceArg(*actual, messages);
+          CheckImplicitInterfaceArg(*actual, messages, context);
         }
       }
     }

diff  --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90
index 84bb2863866b6..8be2f41ccb1d6 100644
--- a/flang/test/Semantics/call02.f90
+++ b/flang/test/Semantics/call02.f90
@@ -26,6 +26,15 @@ subroutine badsubr(dummy)
   call subr(B"1010")
 end subroutine
 
+subroutine s02
+  !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
+  call sub(elem)
+ contains
+  elemental integer function elem()
+    elem = 1
+  end function
+end
+
 module m01
   procedure(sin) :: elem01
   interface
@@ -73,6 +82,18 @@ subroutine test
   end subroutine
 end module
 
+module m03
+ contains
+  subroutine test
+    !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
+    call sub(elem)
+   contains
+    elemental integer function elem()
+      elem = 1
+    end function
+  end
+end
+
 program p03
   logical :: l
   call s1(index)