[flang] Split interoperability warnings, disable some by default

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