[flang-commits] [flang] 9b86a72 - [flang] Catch C721 violations in defined interfaces

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-10-29T16:41:50-07:00
New Revision: 9b86a722c0efcd8e5e72b493daa0a68883d3a7cc

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

LOG: [flang] Catch C721 violations in defined interfaces

Fortran's constraint C721 allows an assumed-length CHARACTER
entity to be declared in a very limited set of circumstances that
does not include an explicit external interface definition.

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

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/call01.f90
    flang/test/Semantics/resolve67.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 7bd26202c4cb..c44037dd5a72 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -970,6 +970,11 @@ void CheckHelper::CheckSubprogram(
       }
     }
   }
+  if (details.isInterface() && !details.isDummy() && details.isFunction() &&
+      IsAssumedLengthCharacter(details.result())) { // C721
+    messages_.Say(details.result().name(),
+        "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
+  }
 }
 
 void CheckHelper::CheckDerivedType(
@@ -1297,6 +1302,12 @@ bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
   } else if (!proc.functionResult.has_value()) {
     msg = "%s procedure '%s' must be a function"_err_en_US;
   } else if (proc.functionResult->IsAssumedLengthCharacter()) {
+    const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};
+    if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {
+      // Error is caught by more general test for interfaces with
+      // assumed-length character function results
+      return true;
+    }
     msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
           " result"_err_en_US;
   } else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {

diff  --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90
index de38bf85fbe2..1b31053e6f79 100644
--- a/flang/test/Semantics/call01.f90
+++ b/flang/test/Semantics/call01.f90
@@ -126,6 +126,7 @@ subroutine s01(f1, f2, fp1, fp2)
   interface
     character*(*) function f2()
     end function
+    !ERROR: A function interface may not declare an assumed-length CHARACTER(*) result
     character*(*) function f4()
     end function
   end interface
@@ -133,8 +134,6 @@ character*(*) function f4()
   print *, f2()
   !ERROR: Assumed-length character function must be defined with a length to be called
   print *, f3()
-  !ERROR: Assumed-length character function must be defined with a length to be called
-  print *, f4()
   print *, fp1()
   print *, fp2()
 end subroutine

diff  --git a/flang/test/Semantics/resolve67.f90 b/flang/test/Semantics/resolve67.f90
index 6ecc738879bf..189092f69b1d 100644
--- a/flang/test/Semantics/resolve67.f90
+++ b/flang/test/Semantics/resolve67.f90
@@ -35,7 +35,7 @@ real function not1(x, y)
 
 module m3
   interface operator(/)
-    !ERROR: OPERATOR(/) function 'divide' may not have assumed-length CHARACTER(*) result
+    !ERROR: A function interface may not declare an assumed-length CHARACTER(*) result
     character(*) function divide(x, y)
       character(*), intent(in) :: x, y
     end
@@ -57,6 +57,23 @@ subroutine y()
       end interface
     end
   end interface
+ contains
+  subroutine s(alcf1, alcf2)
+    interface
+      character(*) function alcf1(x, y)
+        character(*), intent(in) :: x, y
+      end function
+      character(*) function alcf2(x, y)
+        character(*), intent(in) :: x, y
+      end function
+    end interface
+    interface operator(+)
+      !ERROR: OPERATOR(+) function 'alcf1' may not have assumed-length CHARACTER(*) result
+      procedure alcf1
+    end interface
+    !ERROR: OPERATOR(-) function 'alcf2' may not have assumed-length CHARACTER(*) result
+    generic :: operator(-) => alcf2
+  end subroutine
 end
 
 module m4