[flang] Silence over-eager warning about interoperable character length (#97353)

Make the results of the two IsInteroperableIntrinsicType() utility
routines a tri-state std::optional<bool> so that cases where the
character length is simply unknown can be distinguished from those cases
where the length is known and not acceptable. Use this distinction to
not emit a confusing warning about interoperability with C_LOC()
arguments when the length is unknown and might well be acceptable during
execution.

Author: klausler

flang/include/flang/Evaluate/type.h

@@ -485,7 +485,8 @@ int SelectedCharKind(const std::string &, int defaultKind);
 std::optional<DynamicType> ComparisonType(
     const DynamicType &, const DynamicType &);
 
-bool IsInteroperableIntrinsicType(const DynamicType &,
+// Returns nullopt for deferred, assumed, and non-constant lengths.
+std::optional<bool> IsInteroperableIntrinsicType(const DynamicType &,
     const common::LanguageFeatureControl * = nullptr,
     bool checkCharLength = true);
 bool IsCUDAIntrinsicType(const DynamicType &);

flang/include/flang/Semantics/type.h

@@ -459,7 +459,7 @@ inline const DerivedTypeSpec *DeclTypeSpec::AsDerived() const {
   return const_cast<DeclTypeSpec *>(this)->AsDerived();
 }
 
-bool IsInteroperableIntrinsicType(
+std::optional<bool> IsInteroperableIntrinsicType(
     const DeclTypeSpec &, const common::LanguageFeatureControl &);
 
 } // namespace Fortran::semantics

flang/lib/Evaluate/intrinsics.cpp

@@ -2831,7 +2831,8 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
             }
           }
         } else if (!IsInteroperableIntrinsicType(
-                       *type, &context.languageFeatures()) &&
+                       *type, &context.languageFeatures())
+                        .value_or(true) &&
             context.languageFeatures().ShouldWarn(
                 common::UsageWarning::Interoperability)) {
           context.messages().Say(at,
@@ -2933,24 +2934,25 @@ 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()) &&
+          !IsInteroperableIntrinsicType(typeAndShape->type()).value_or(true) &&
           context.languageFeatures().ShouldWarn(
               common::UsageWarning::Interoperability)) {
         context.messages().Say(arguments[0]->sourceLocation(),
             "C_LOC() argument has non-interoperable intrinsic type, kind, or length"_warn_en_US);
       }
 
-      return SpecificCall{SpecificIntrinsic{"__builtin_c_loc"s,
-                              characteristics::Procedure{
-                                  characteristics::FunctionResult{
-                                      DynamicType{GetBuiltinDerivedType(
-                                          builtinsScope_, "__builtin_c_ptr")}},
-                                  characteristics::DummyArguments{
-                                      characteristics::DummyArgument{"x"s,
-                                          characteristics::DummyDataObject{
-                                              std::move(*typeAndShape)}}},
-                                  characteristics::Procedure::Attrs{
-                                      characteristics::Procedure::Attr::Pure}}},
+      characteristics::DummyDataObject ddo{std::move(*typeAndShape)};
+      ddo.intent = common::Intent::In;
+      return SpecificCall{
+          SpecificIntrinsic{"__builtin_c_loc"s,
+              characteristics::Procedure{
+                  characteristics::FunctionResult{
+                      DynamicType{GetBuiltinDerivedType(
+                          builtinsScope_, "__builtin_c_ptr")}},
+                  characteristics::DummyArguments{
+                      characteristics::DummyArgument{"x"s, std::move(ddo)}},
+                  characteristics::Procedure::Attrs{
+                      characteristics::Procedure::Attr::Pure}}},
           std::move(arguments)};
     }
   }

flang/lib/Evaluate/type.cpp

@@ -807,7 +807,7 @@ std::optional<DynamicType> ComparisonType(
   }
 }
 
-bool IsInteroperableIntrinsicType(const DynamicType &type,
+std::optional<bool> IsInteroperableIntrinsicType(const DynamicType &type,
     const common::LanguageFeatureControl *features, bool checkCharLength) {
   switch (type.category()) {
   case TypeCategory::Integer:
@@ -819,10 +819,17 @@ bool IsInteroperableIntrinsicType(const DynamicType &type,
   case TypeCategory::Logical:
     return type.kind() == 1; // C_BOOL
   case TypeCategory::Character:
-    if (checkCharLength && type.knownLength().value_or(0) != 1) {
+    if (type.kind() != 1) { // C_CHAR
       return false;
+    } else if (checkCharLength) {
+      if (type.knownLength()) {
+        return *type.knownLength() == 1;
+      } else {
+        return std::nullopt;
+      }
+    } else {
+      return true;
     }
-    return type.kind() == 1 /* C_CHAR */;
   default:
     // Derived types are tested in Semantics/check-declarations.cpp
     return false;

flang/lib/Semantics/check-declarations.cpp

@@ -2982,7 +2982,8 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
             msgs.Annex(std::move(bad));
           }
         } else if (!IsInteroperableIntrinsicType(
-                       *type, context_.languageFeatures())) {
+                       *type, context_.languageFeatures())
+                        .value_or(false)) {
           auto maybeDyType{evaluate::DynamicType::From(*type)};
           if (type->category() == DeclTypeSpec::Logical) {
             if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
@@ -3084,7 +3085,8 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) {
         type->characterTypeSpec().length().isDeferred()) {
       // ok; F'2023 18.3.7 p2(6)
     } else if (derived ||
-        IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
+        IsInteroperableIntrinsicType(*type, context_.languageFeatures())
+            .value_or(false)) {
       // F'2023 18.3.7 p2(4,5)
     } else if (type->category() == DeclTypeSpec::Logical) {
       if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool) &&

flang/lib/Semantics/type.cpp

@@ -891,10 +891,13 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {
   return o << x.AsFortran();
 }
 
-bool IsInteroperableIntrinsicType(
+std::optional<bool> IsInteroperableIntrinsicType(
     const DeclTypeSpec &type, const common::LanguageFeatureControl &features) {
-  auto dyType{evaluate::DynamicType::From(type)};
-  return dyType && IsInteroperableIntrinsicType(*dyType, &features);
+  if (auto dyType{evaluate::DynamicType::From(type)}) {
+    return IsInteroperableIntrinsicType(*dyType, &features);
+  } else {
+    return std::nullopt;
+  }
 }
 
 } // namespace Fortran::semantics

flang/test/Semantics/c_loc01.f90

@@ -8,7 +8,7 @@ module m
  contains
   subroutine subr
   end
-  subroutine test(assumedType, poly, nclen)
+  subroutine test(assumedType, poly, nclen, n)
     type(*), target :: assumedType
     class(*), target ::  poly
     type(c_ptr) cp
@@ -19,9 +19,12 @@ subroutine test(assumedType, poly, nclen)
     real, target :: arr(3)
     type(hasLen(1)), target :: clen
     type(hasLen(*)), target :: nclen
+    integer, intent(in) :: n
     character(2), target :: ch
     real :: arr1(purefun1(c_loc(targ))) ! ok
     real :: arr2(purefun2(c_funloc(subr))) ! ok
+    character(:), allocatable, target :: deferred
+    character(n), pointer :: p2ch
     !ERROR: C_LOC() argument must be a data pointer or target
     cp = c_loc(notATarget)
     !ERROR: C_LOC() argument must be a data pointer or target
@@ -39,7 +42,9 @@ subroutine test(assumedType, poly, nclen)
     cp = c_loc(ch(2:1))
     !WARNING: C_LOC() argument has non-interoperable intrinsic type, kind, or length
     cp = c_loc(ch)
-    cp = c_loc(ch(1:1)) ! ok)
+    cp = c_loc(ch(1:1)) ! ok
+    cp = c_loc(deferred) ! ok
+    cp = c_loc(p2ch) ! ok
     !ERROR: PRIVATE name '__address' is only accessible within module '__fortran_builtins'
     cp = c_ptr(0)
     !ERROR: PRIVATE name '__address' is only accessible within module '__fortran_builtins'