[flang] Split interoperability warnings, disable some by default (#111922)

Type interoperability warnings current issue for intrinsic types when
their type, kind, or length do not meet the requirements for C
interoperability. This turns out to be too noisy for the case of
one-byte characters with lengths other than one when creating C pointers
from C_LOC or C_F_POINTER -- it is not uncommon for programs to use
pointers to longer character objects.

So split the interoperability warning so that the case of a known bad
character length for an otherwise interoperable type is controlled by
its own UsageWarning enumerator, and leave that usage warning off by
default. This will better fit expectations in the default case while
still showing a warning under -pedantic.

Author: klausler

flang/include/flang/Common/Fortran-features.h

@@ -63,9 +63,9 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     F202XAllocatableBreakingChange, OptionalMustBePresent, CommonBlockPadding,
     LogicalVsCBool, BindCCharLength, ProcDummyArgShapes, ExternalNameConflict,
     FoldingException, FoldingAvoidsRuntimeCrash, FoldingValueChecks,
-    FoldingFailure, FoldingLimit, Interoperability, Bounds, Preprocessing,
-    Scanning, OpenAccUsage, ProcPointerCompatibility, VoidMold,
-    KnownBadImplicitInterface, EmptyCase, CaseOverflow, CUDAUsage,
+    FoldingFailure, FoldingLimit, Interoperability, CharacterInteroperability,
+    Bounds, Preprocessing, Scanning, OpenAccUsage, ProcPointerCompatibility,
+    VoidMold, KnownBadImplicitInterface, EmptyCase, CaseOverflow, CUDAUsage,
     IgnoreTKRUsage, ExternalInterfaceMismatch, DefinedOperatorArgs, Final,
     ZeroDoStep, UnusedForallIndex, OpenMPUsage, ModuleFile, DataLength,
     IgnoredDirective, HomonymousSpecific, HomonymousResult,

flang/lib/Common/Fortran-features.cpp

@@ -48,6 +48,7 @@ LanguageFeatureControl::LanguageFeatureControl() {
   warnUsage_.set(UsageWarning::FoldingFailure);
   warnUsage_.set(UsageWarning::FoldingLimit);
   warnUsage_.set(UsageWarning::Interoperability);
+  // CharacterInteroperability warnings about length are off by default
   warnUsage_.set(UsageWarning::Bounds);
   warnUsage_.set(UsageWarning::Preprocessing);
   warnUsage_.set(UsageWarning::Scanning);

flang/lib/Evaluate/intrinsics.cpp

@@ -2861,12 +2861,22 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
           }
         } else if (!IsInteroperableIntrinsicType(
                        *type, &context.languageFeatures())
-                        .value_or(true) &&
-            context.languageFeatures().ShouldWarn(
-                common::UsageWarning::Interoperability)) {
-          context.messages().Say(common::UsageWarning::Interoperability, at,
-              "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type %s"_warn_en_US,
-              type->AsFortran());
+                        .value_or(true)) {
+          if (type->category() == TypeCategory::Character &&
+              type->kind() == 1) {
+            if (context.languageFeatures().ShouldWarn(
+                    common::UsageWarning::CharacterInteroperability)) {
+              context.messages().Say(
+                  common::UsageWarning::CharacterInteroperability, at,
+                  "FPTR= argument to C_F_POINTER() should not have the non-interoperable character length %s"_warn_en_US,
+                  type->AsFortran());
+            }
+          } else if (context.languageFeatures().ShouldWarn(
+                         common::UsageWarning::Interoperability)) {
+            context.messages().Say(common::UsageWarning::Interoperability, at,
+                "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind %s"_warn_en_US,
+                type->AsFortran());
+          }
         }
         if (ExtractCoarrayRef(*expr)) {
           context.messages().Say(at,
@@ -2963,12 +2973,23 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
         context.messages().Say(arguments[0]->sourceLocation(),
             "C_LOC() argument may not be zero-length character"_err_en_US);
       } else if (typeAndShape->type().category() != TypeCategory::Derived &&
-          !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true) &&
-          context.languageFeatures().ShouldWarn(
-              common::UsageWarning::Interoperability)) {
-        context.messages().Say(common::UsageWarning::Interoperability,
-            arguments[0]->sourceLocation(),
-            "C_LOC() argument has non-interoperable intrinsic type, kind, or length"_warn_en_US);
+          !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true)) {
+        if (typeAndShape->type().category() == TypeCategory::Character &&
+            typeAndShape->type().kind() == 1) {
+          // Default character kind, but length is not known to be 1
+          if (context.languageFeatures().ShouldWarn(
+                  common::UsageWarning::CharacterInteroperability)) {
+            context.messages().Say(
+                common::UsageWarning::CharacterInteroperability,
+                arguments[0]->sourceLocation(),
+                "C_LOC() argument has non-interoperable character length"_warn_en_US);
+          }
+        } else if (context.languageFeatures().ShouldWarn(
+                       common::UsageWarning::Interoperability)) {
+          context.messages().Say(common::UsageWarning::Interoperability,
+              arguments[0]->sourceLocation(),
+              "C_LOC() argument has non-interoperable intrinsic type or kind"_warn_en_US);
+        }
       }
 
       characteristics::DummyDataObject ddo{std::move(*typeAndShape)};

flang/test/Semantics/c_f_pointer.f90

@@ -18,6 +18,7 @@ program test
   end type
   type(notBindCType), pointer :: notBindC
   character(2), pointer :: c2ptr
+  character(1,4), pointer :: unicodePtr
   rankTwoArray = reshape([1, 2, 3, 4], shape(rankTwoArray))
   call c_f_pointer(scalarC, scalarIntF) ! ok
   call c_f_pointer(scalarC, arrayIntF, [1_8]) ! ok
@@ -48,6 +49,8 @@ program test
   call c_f_pointer(scalarC, unlimited)
   !WARNING: FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)
   call c_f_pointer(scalarC, notBindC)
-  !WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type CHARACTER(KIND=1,LEN=2_8)
+  !WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable character length CHARACTER(KIND=1,LEN=2_8)
   call c_f_pointer(scalarC, c2ptr)
+  !WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind CHARACTER(KIND=4,LEN=1_8)
+  call c_f_pointer(scalarC, unicodePtr)
 end program

flang/test/Semantics/c_loc01.f90

@@ -21,6 +21,7 @@ subroutine test(assumedType, poly, nclen, n)
     type(hasLen(*)), target :: nclen
     integer, intent(in) :: n
     character(2), target :: ch
+    character(1,4), target :: unicode
     real :: arr1(purefun1(c_loc(targ))) ! ok
     real :: arr2(purefun2(c_funloc(subr))) ! ok
     character(:), allocatable, target :: deferred
@@ -40,8 +41,10 @@ subroutine test(assumedType, poly, nclen, n)
     cp = c_loc(nclen)
     !ERROR: C_LOC() argument may not be zero-length character
     cp = c_loc(ch(2:1))
-    !WARNING: C_LOC() argument has non-interoperable intrinsic type, kind, or length
+    !WARNING: C_LOC() argument has non-interoperable character length
     cp = c_loc(ch)
+    !WARNING: C_LOC() argument has non-interoperable intrinsic type or kind
+    cp = c_loc(unicode)
     cp = c_loc(ch(1:1)) ! ok
     cp = c_loc(deferred) ! ok
     cp = c_loc(p2ch) ! ok