[flang-commits] [PATCH] D109926: flang] Upgrade warning to error in case of PURE procedure

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: PeteSteinfeld.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
klausler requested review of this revision.

[A procedure actual argument to a PURE procedure should be required
to have an explicit interface.  Implicit-interface actual arguments
to non-PURE procedures remain a warning.


https://reviews.llvm.org/D109926

Files:
  flang/lib/Semantics/check-call.cpp
  flang/test/Semantics/call12.f90


Index: flang/test/Semantics/call12.f90
===================================================================
--- flang/test/Semantics/call12.f90
+++ flang/test/Semantics/call12.f90
@@ -18,6 +18,14 @@
     real, allocatable :: co[:]
   end type
  contains
+  integer pure function purefunc(x)
+    integer, intent(in) :: x
+    purefunc = x
+  end function
+  integer pure function f00(p0)
+    procedure(purefunc) :: p0
+    f00 = p0(1)
+  end function
   pure function test(ptr, in, hpd)
     use used
     type(t), pointer :: ptr, ptr2
@@ -29,6 +37,7 @@
     type(hasCoarray), pointer :: hcp
     integer :: n
     common /block/ y
+    external :: extfunc
     !ERROR: Pure subprogram 'test' may not define 'x' because it is host-associated
     x%a = 0.
     !ERROR: Pure subprogram 'test' may not define 'y' because it is in a COMMON block
@@ -63,6 +72,8 @@
     hp = hpd ! C1594(5)
     !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
     allocate(alloc, source=hpd)
+    !ERROR: Actual procedure argument for dummy argument 'p0=' of a PURE procedure must have an explicit interface
+    n = f00(extfunc)
    contains
     pure subroutine internal
       type(hasPtr) :: localhp
Index: flang/lib/Semantics/check-call.cpp
===================================================================
--- flang/lib/Semantics/check-call.cpp
+++ flang/lib/Semantics/check-call.cpp
@@ -502,13 +502,14 @@
 }
 
 static void CheckProcedureArg(evaluate::ActualArgument &arg,
-    const characteristics::DummyProcedure &proc, const std::string &dummyName,
+    const characteristics::Procedure &proc,
+    const characteristics::DummyProcedure &dummy, const std::string &dummyName,
     evaluate::FoldingContext &context) {
   parser::ContextualMessages &messages{context.messages()};
-  const characteristics::Procedure &interface{proc.procedure.value()};
+  const characteristics::Procedure &interface { dummy.procedure.value() };
   if (const auto *expr{arg.UnwrapExpr()}) {
     bool dummyIsPointer{
-        proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
+        dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
     const auto *argProcDesignator{
         std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
     const auto *argProcSymbol{
@@ -549,6 +550,10 @@
                     "Actual procedure argument has interface incompatible with %s"_err_en_US,
                     dummyName);
                 return;
+              } else if (proc.IsPure()) {
+                messages.Say(
+                    "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
+                    dummyName);
               } else {
                 messages.Say(
                     "Actual procedure argument has an implicit interface "
@@ -594,7 +599,7 @@
       }
     }
     if (interface.HasExplicitInterface() && dummyIsPointer &&
-        proc.intent != common::Intent::In) {
+        dummy.intent != common::Intent::In) {
       const Symbol *last{GetLastSymbol(*expr)};
       if (!(last && IsProcedurePointer(*last))) {
         // 15.5.2.9(5) -- dummy procedure POINTER
@@ -661,8 +666,8 @@
               }
             }
           },
-          [&](const characteristics::DummyProcedure &proc) {
-            CheckProcedureArg(arg, proc, dummyName, context);
+          [&](const characteristics::DummyProcedure &dummy) {
+            CheckProcedureArg(arg, proc, dummy, dummyName, context);
           },
           [&](const characteristics::AlternateReturn &) {
             // All semantic checking is done elsewhere


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D109926.373064.patch
Type: text/x-patch
Size: 3687 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20210916/b910925f/attachment.bin>