[flang] Catch C721 violations in defined interfaces

[klausler]

Summary

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.

flang/lib/Semantics/check-declarations.cpp

if (details.isDummy()) {
       for (const Symbol *dummy : details.dummyArgs()) {
         if (!dummy) { // C15100
           messages_.Say(
               "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
         }
       }
     }
   }
+  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(
     const Symbol &derivedType, const DerivedTypeDetails &details) {
   if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
     messages_.Say("The derived type '%s' has not been defined"_err_en_US,
         derivedType.name());
   }
auto checkDefinedOperatorArgs{
         bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};
         return arg0Defined && arg1Defined;
       }};
   if (specific.attrs().test(Attr::NOPASS)) { // C774
     msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
   } 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())}) {
     msg = std::move(m);
   } else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
     return false; // error was reported
   } else if (ConflictsWithIntrinsicOperator(kind, proc)) {
     msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;

flang/test/Semantics/call01.f90

 subroutine s01(f1, f2, fp1, fp2)
   character*(*) :: f1, f3, fp1
   external :: f1, f3
   pointer :: fp1
   procedure(character*(*)), pointer :: 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
   print *, f1()
   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

flang/test/Semantics/resolve67.f90

interface operator(.not.)
     real function not1(x, y)
       real, intent(in) :: x, y
     end
   end interface
 end
 
 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
   end interface
   interface operator(<)
     !ERROR: In OPERATOR(<) function 'lt1', dummy argument 'x' must have INTENT(IN) or VALUE attribute
     !ERROR: In OPERATOR(<) function 'lt1', dummy argument 'y' may not be OPTIONAL
     logical function lt1(x, y)
       logical :: x
       real, value, optional :: y
     end
     !ERROR: In OPERATOR(<) function 'lt2', dummy argument 'y' must be a data object
     logical function lt2(x, y)
       logical, intent(in) :: x
       intent(in) :: y
       interface
         subroutine y()
         end
       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
   interface operator(+)
     !ERROR: OPERATOR(+) function 'add' conflicts with intrinsic operator
     complex function add(x, y)
       real, intent(in) :: x
       integer, value :: y