[flang] Check for non-interoperable intrinsic types in BIND(C) derived types

[klausler]

Summary

Every component of a BIND(C) interoperable derived type must have an
interoperable type. Semantics was checking components with derived types,
but not components with intrinsic types.

flang/include/flang/Evaluate/type.h

 // TargetCharactertics.
 
 // Given the dynamic types and kinds of two operands, determine the common
 // type to which they must be converted in order to be compared with
 // intrinsic OPERATOR(==) or .EQV.
 std::optional<DynamicType> ComparisonType(
     const DynamicType &, const DynamicType &);
 
+bool IsInteroperableIntrinsicType(const DynamicType &);
+
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
   M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)
 #define EXPAND_FOR_EACH_REAL_KIND(M, P, S) \
   M(P, S, 2) M(P, S, 3) M(P, S, 4) M(P, S, 8) M(P, S, 10) M(P, S, 16)
 #define EXPAND_FOR_EACH_COMPLEX_KIND(M, P, S) EXPAND_FOR_EACH_REAL_KIND(M, P, S)
 #define EXPAND_FOR_EACH_CHARACTER_KIND(M, P, S) M(P, S, 1) M(P, S, 2) M(P, S, 4)
 #define EXPAND_FOR_EACH_LOGICAL_KIND(M, P, S) \

flang/include/flang/Semantics/type.h

inline DerivedTypeSpec *DeclTypeSpec::AsDerived() {
   default:
     return nullptr;
   }
 }
 inline const DerivedTypeSpec *DeclTypeSpec::AsDerived() const {
   return const_cast<DeclTypeSpec *>(this)->AsDerived();
 }
 
+bool IsInteroperableIntrinsicType(const DeclTypeSpec &);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TYPE_H_

flang/lib/Evaluate/type.cpp

case TypeCategory::Logical:
     default:
       return std::nullopt;
     }
   default:
     return std::nullopt;
   }
 }
 
+bool IsInteroperableIntrinsicType(const DynamicType &type) {
+  switch (type.category()) {
+  case TypeCategory::Integer:
+    return true;
+  case TypeCategory::Real:
+  case TypeCategory::Complex:
+    return type.kind() >= 4; // no short or half floats
+  case TypeCategory::Logical:
+    return type.kind() == 1; // C_BOOL
+  case TypeCategory::Character:
+    return type.kind() == 1 /* C_CHAR */ && type.knownLength().value_or(0) == 1;
+  default:
+    // Derived types are tested in Semantics/check-declarations.cpp
+    return false;
+  }
+}
+
 } // namespace Fortran::evaluate

flang/lib/Semantics/check-declarations.cpp

if (derived->sequence()) { // C1801
               "A derived type with the BIND attribute cannot have a type bound procedure"_err_en_US);
           context_.SetError(symbol);
           break;
         } else if (IsAllocatableOrPointer(*component)) { // C1806
           messages_.Say(symbol.name(),
               "A derived type with the BIND attribute cannot have a pointer or allocatable component"_err_en_US);
           context_.SetError(symbol);
           break;
-        } else if (component->GetType() && component->GetType()->AsDerived() &&
-            !component->GetType()->AsDerived()->typeSymbol().attrs().test(
-                Attr::BIND_C)) {
-          messages_.Say(component->GetType()->AsDerived()->typeSymbol().name(),
+        } else if (const auto *type{component->GetType()}) {
+          if (const auto *derived{type->AsDerived()}) {
+            if (!derived->typeSymbol().attrs().test(Attr::BIND_C)) {
+              messages_.Say(
+                  component->GetType()->AsDerived()->typeSymbol().name(),
                   "The component of the interoperable derived type must have the BIND attribute"_err_en_US);
               context_.SetError(symbol);
               break;
             }
+          } else if (!IsInteroperableIntrinsicType(*type)) {
+            messages_.Say(component->name(),
+                "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
+            context_.SetError(symbol);
+            break;
+          }
+        }
       }
     }
     if (derived->componentNames().empty() &&
         !FindModuleFileContaining(symbol.owner())) { // C1805
       messages_.Say(symbol.name(),
           "A derived type with the BIND attribute is empty"_port_en_US);
     }
   }

flang/lib/Semantics/type.cpp

 //===-- lib/Semantics/type.cpp --------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Semantics/type.h"
 #include "check-declarations.h"
 #include "compute-offsets.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
+#include "flang/Evaluate/type.h"
 #include "flang/Parser/characters.h"
 #include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 
 namespace Fortran::semantics {
case ClassStar:
     return "CLASS(*)";
   }
 }
 
 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {
   return o << x.AsFortran();
 }
 
+bool IsInteroperableIntrinsicType(const DeclTypeSpec &type) {
+  auto dyType{evaluate::DynamicType::From(type)};
+  return dyType && IsInteroperableIntrinsicType(*dyType);
+}
+
 } // namespace Fortran::semantics

flang/test/Semantics/bind-c06.f90

type :: t8
     integer :: x
   end type
 
   type, bind(c) :: t9
     type(t8) :: y
     integer :: z
   end type
 
+  type, bind(c) :: t10
+    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    character(len=2) x
+  end type
+  type, bind(c) :: t11
+    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    character(kind=2) x
+  end type
+  type, bind(c) :: t12
+    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    logical(kind=8) x
+  end type
+  type, bind(c) :: t13
+    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    real(kind=2) x
+  end type
+  type, bind(c) :: t14
+    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    complex(kind=2) x
+  end type
+
 end