[llvm-branch-commits] [flang] 1e1a011 - [flang] Disallow INTENT attribute on procedure dummy arguments

[Peter Steinfeld via llvm-branch-commits]

Author: Peter Steinfeld
Date: 2021-01-15T08:53:43-08:00
New Revision: 1e1a011b09d0e6e9ff62b37721906485c386708c

URL: https://github.com/llvm/llvm-project/commit/1e1a011b09d0e6e9ff62b37721906485c386708c
DIFF: https://github.com/llvm/llvm-project/commit/1e1a011b09d0e6e9ff62b37721906485c386708c.diff

LOG: [flang] Disallow INTENT attribute on procedure dummy arguments

C843 states that "An entity with the INTENT attribute shall be a dummy
data object or a dummy procedure pointer."  This change enforces that
and fixes some tests that erroneously violated this rule.

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

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/assign03.f90
    flang/test/Semantics/call09.f90
    flang/test/Semantics/separate-mp02.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 9bb82156e955..aca5392e507f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -632,6 +632,14 @@ void CheckHelper::CheckArraySpec(
 void CheckHelper::CheckProcEntity(
     const Symbol &symbol, const ProcEntityDetails &details) {
   if (details.isDummy()) {
+    if (!symbol.attrs().test(Attr::POINTER) && // C843
+        (symbol.attrs().test(Attr::INTENT_IN) ||
+            symbol.attrs().test(Attr::INTENT_OUT) ||
+            symbol.attrs().test(Attr::INTENT_INOUT))) {
+      messages_.Say("A dummy procedure without the POINTER attribute"
+                    " may not have an INTENT attribute"_err_en_US);
+    }
+
     const Symbol *interface{details.interface().symbol()};
     if (!symbol.attrs().test(Attr::INTRINSIC) &&
         (symbol.attrs().test(Attr::ELEMENTAL) ||

diff  --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index 1435342b1ead..c53bb0ed291a 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -42,7 +42,7 @@ function f()
 
   ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
   subroutine s4(s_dummy)
-    procedure(s), intent(in) :: s_dummy
+    procedure(s) :: s_dummy
     procedure(s), pointer :: p, q
     procedure(), pointer :: r
     integer :: i

diff  --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index e7f22e32ed44..36aaa8f4ab46 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -1,5 +1,8 @@
 ! RUN: %S/test_errors.sh %s %t %f18
 ! Test 15.5.2.9(2,3,5) dummy procedure requirements
+! C843
+!   An entity with the INTENT attribute shall be a dummy data object or a 
+!   dummy procedure pointer.
 
 module m
  contains
@@ -22,6 +25,10 @@ subroutine s02(p)
   subroutine s03(p)
     procedure(realfunc) :: p
   end subroutine
+  subroutine s04(p)
+    !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
+    procedure(realfunc), intent(in) :: p
+  end subroutine
 
   subroutine selemental1(p)
     procedure(cos) :: p ! ok

diff  --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90
index 47abc83bff1e..6d620e71118b 100644
--- a/flang/test/Semantics/separate-mp02.f90
+++ b/flang/test/Semantics/separate-mp02.f90
@@ -157,9 +157,9 @@ module subroutine s3() bind(c, name="s3" // suffix)
 module m3
   interface
     module subroutine s1(x, y, z)
-      procedure(real), intent(in) :: x
-      procedure(real), intent(out) :: y
-      procedure(real), intent(out) :: z
+      procedure(real), pointer, intent(in) :: x
+      procedure(real), pointer, intent(out) :: y
+      procedure(real), pointer, intent(out) :: z
     end
     module subroutine s2(x, y)
       procedure(real), pointer :: x
@@ -171,11 +171,11 @@ module subroutine s2(x, y)
 submodule(m3) sm3
 contains
   module subroutine s1(x, y, z)
-    procedure(real), intent(in) :: x
+    procedure(real), pointer, intent(in) :: x
     !ERROR: The intent of dummy argument 'y' does not match the intent of the corresponding argument in the interface body
-    procedure(real), intent(inout) :: y
+    procedure(real), pointer, intent(inout) :: y
     !ERROR: The intent of dummy argument 'z' does not match the intent of the corresponding argument in the interface body
-    procedure(real) :: z
+    procedure(real), pointer :: z
   end
   module subroutine s2(x, y)
     !ERROR: Dummy argument 'x' has the OPTIONAL attribute; the corresponding argument in the interface body does not