[flang-commits] [flang] f9c0859 - [flang] Check for attributes specific to dummy arguments

[Peter Steinfeld via flang-commits]

Author: Peter Steinfeld
Date: 2021-04-26T09:27:55-07:00
New Revision: f9c0859e9687294a3b6b2e797faf4b7ee62c60ce

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

LOG: [flang] Check for attributes specific to dummy arguments

We were not checking that attributes that are supposed to be specific to
dummy arguments were not being used for local entities.  I added the checks
along with tests for them.

After implementing these new checks, I found that one of the tests in
separate-mp02.f90 was erroneous, and I fixed it.

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

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/resolve58.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 0b28a3188e5d..0e9d4da723bb 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -490,6 +490,14 @@ void CheckHelper::CheckObjectEntity(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
+  } else if (symbol.attrs().test(Attr::INTENT_IN) ||
+      symbol.attrs().test(Attr::INTENT_OUT) ||
+      symbol.attrs().test(Attr::INTENT_INOUT)) {
+    messages_.Say("INTENT attributes may apply only to a dummy "
+                  "argument"_err_en_US); // C843
+  } else if (IsOptional(symbol)) {
+    messages_.Say("OPTIONAL attribute may apply only to a dummy "
+                  "argument"_err_en_US); // C849
   }
   if (IsStaticallyInitialized(symbol, true /* ignore DATA inits */)) { // C808
     CheckPointerInitialization(symbol);
@@ -618,8 +626,9 @@ void CheckHelper::CheckArraySpec(
   } else if (isAssumedRank) { // C837
     msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
   } else if (isImplied) {
-    if (!IsNamedConstant(symbol)) { // C836
-      msg = "Implied-shape array '%s' must be a named constant"_err_en_US;
+    if (!IsNamedConstant(symbol)) { // C835, C836
+      msg = "Implied-shape array '%s' must be a named constant or a "
+            "dummy argument"_err_en_US;
     }
   } else if (IsNamedConstant(symbol)) {
     if (!isExplicit && !isImplied) {
@@ -664,6 +673,14 @@ void CheckHelper::CheckProcEntity(
       // function SIN as an actual argument.
       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
     }
+  } else if (symbol.attrs().test(Attr::INTENT_IN) ||
+      symbol.attrs().test(Attr::INTENT_OUT) ||
+      symbol.attrs().test(Attr::INTENT_INOUT)) {
+    messages_.Say("INTENT attributes may apply only to a dummy "
+                  "argument"_err_en_US); // C843
+  } else if (IsOptional(symbol)) {
+    messages_.Say("OPTIONAL attribute may apply only to a dummy "
+                  "argument"_err_en_US); // C849
   } else if (symbol.owner().IsDerivedType()) {
     if (!symbol.attrs().test(Attr::POINTER)) { // C756
       const auto &name{symbol.name()};

diff  --git a/flang/test/Semantics/resolve58.f90 b/flang/test/Semantics/resolve58.f90
index 8c1cf26730d3..ea814bd99eac 100644
--- a/flang/test/Semantics/resolve58.f90
+++ b/flang/test/Semantics/resolve58.f90
@@ -27,8 +27,8 @@ subroutine s2(a, b, c)
 subroutine s3(a, b)
   real :: a(*)
   !ERROR: Dummy array argument 'b' may not have implied shape
-  real :: b(*,*)  ! C836
-  !ERROR: Implied-shape array 'c' must be a named constant
+  real :: b(*,*)  ! C835, C836
+  !ERROR: Implied-shape array 'c' must be a named constant or a dummy argument
   real :: c(*)  ! C836
   !ERROR: Named constant 'd' array must have constant or implied shape
   integer, parameter :: d(:) = [1, 2, 3]
@@ -56,3 +56,25 @@ subroutine s5()
   allocatable :: a
   allocatable :: b
 end subroutine
+
+subroutine s6()
+!C835   An object whose array bounds are specified by an 
+!  implied-shape-or-assumed-size-spec shall be a dummy data object or a named
+!  constant.
+!
+!C843   An entity with the INTENT attribute shall be a dummy data object or a 
+!  dummy procedure pointer.
+!
+!C849   An entity with the OPTIONAL attribute shall be a dummy argument.
+
+  !ERROR: Implied-shape array 'local1' must be a named constant or a dummy argument
+  real, dimension (*) :: local1
+  !ERROR: INTENT attributes may apply only to a dummy argument
+  real, intent(in) :: local2
+  !ERROR: INTENT attributes may apply only to a dummy argument
+  procedure(), intent(in) :: p1
+  !ERROR: OPTIONAL attribute may apply only to a dummy argument
+  real, optional :: local3
+  !ERROR: OPTIONAL attribute may apply only to a dummy argument
+  procedure(), optional :: p2
+end subroutine

diff  --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90
index 9fcec396d53e..5135ccf734f9 100644
--- a/flang/test/Semantics/separate-mp02.f90
+++ b/flang/test/Semantics/separate-mp02.f90
@@ -109,10 +109,10 @@ module subroutine s1(x, y, z)
     real, intent(out) :: y
     real :: z
   end
-  !ERROR: Dummy argument name 'z' does not match corresponding name 'y' in interface body
   module subroutine s2(x, z)
     real, intent(in) :: x
-    real, intent(out) :: y
+  !ERROR: Dummy argument name 'z' does not match corresponding name 'y' in interface body
+    real, intent(out) :: z
   end
   module subroutine s3(x, y)
     !ERROR: Dummy argument 'x' is a procedure; the corresponding argument in the interface body is not