[flang] CUDA Fortran - part 3/5: declarations checking

[klausler]

Summary

Implements checks for CUDA Fortran attributes on objects, types, and
subprograms. Includes a couple downgrades of existing errors into
warnings that were exposed during testing.

Depends on https://reviews.llvm.org/D150159 &
https://reviews.llvm.org/D150161.

[klausler]

Fix clang-format issue preventing CI build.

[clementval]

LGTM

[klausler]

Update LAUNCH_BOUNDS() in test.

[klausler]

Rebase to current head.

[klausler]

Rebase to current head.

flang/include/flang/Evaluate/type.h

 // templates, like expressions, over the supported types and kinds.
 
 #include "common.h"
 #include "complex.h"
 #include "formatting.h"
 #include "integer.h"
 #include "logical.h"
 #include "real.h"
+#include "flang/Common/Fortran-features.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Common/idioms.h"
 #include "flang/Common/real.h"
 #include "flang/Common/template.h"
 #include <cinttypes>
 #include <optional>
 #include <string>
 #include <type_traits>

 // 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 &, bool checkCharLength = true);
+bool IsInteroperableIntrinsicType(const DynamicType &,
+    const common::LanguageFeatureControl * = nullptr,
+    bool checkCharLength = true);
+bool IsCUDAIntrinsicType(const DynamicType &);
 
 // Determine whether two derived type specs are sufficiently identical
 // to be considered the "same" type even if declared separately.
 bool AreSameDerivedType(
     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y);
 
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_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 &);
+bool IsInteroperableIntrinsicType(
+    const DeclTypeSpec &, const common::LanguageFeatureControl &);
 
 } // 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, bool checkCharLength) {
+bool IsInteroperableIntrinsicType(const DynamicType &type,
+    const common::LanguageFeatureControl *features, bool checkCharLength) {
   switch (type.category()) {
   case TypeCategory::Integer:
     return true;
   case TypeCategory::Real:
   case TypeCategory::Complex:
-    return type.kind() >= 4; // no short or half floats
+    return (features && features->IsEnabled(common::LanguageFeature::CUDA)) ||
+        type.kind() >= 4; // no short or half floats
   case TypeCategory::Logical:
     return type.kind() == 1; // C_BOOL
   case TypeCategory::Character:
     if (checkCharLength && type.knownLength().value_or(0) != 1) {
       return false;
     }
     return type.kind() == 1 /* C_CHAR */;
   default:
     // Derived types are tested in Semantics/check-declarations.cpp
     return false;
   }
 }
 
+bool IsCUDAIntrinsicType(const DynamicType &type) {
+  switch (type.category()) {
+  case TypeCategory::Integer:
+  case TypeCategory::Logical:
+    return type.kind() <= 8;
+  case TypeCategory::Real:
+    return type.kind() >= 2 && type.kind() <= 8;
+  case TypeCategory::Complex:
+    return type.kind() == 2 || type.kind() == 4 || type.kind() == 8;
+  case TypeCategory::Character:
+    return type.kind() == 1;
+  default:
+    // Derived types are tested in Semantics/check-declarations.cpp
+    return false;
+  }
+}
+
 } // namespace Fortran::evaluate

flang/lib/Semantics/check-declarations.cpp

private:
   template <typename... A>
   parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
     parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
     if (msg && messages_.at().begin() != symbol.name().begin()) {
       evaluate::AttachDeclaration(*msg, symbol);
     }
     return msg;
   }
+  template <typename... A> parser::Message *WarnIfNotInModuleFile(A &&...x) {
+    if (FindModuleFileContaining(context_.FindScope(messages_.at()))) {
+      return nullptr;
+    }
+    return messages_.Say(std::forward<A>(x)...);
+  }
+  template <typename... A>
+  parser::Message *WarnIfNotInModuleFile(parser::CharBlock source, A &&...x) {
+    if (FindModuleFileContaining(context_.FindScope(source))) {
+      return nullptr;
+    }
+    return messages_.Say(source, std::forward<A>(x)...);
+  }
   bool IsResultOkToDiffer(const FunctionResult &);
   void CheckGlobalName(const Symbol &);
   void CheckExplicitSave(const Symbol &);
   void CheckBindC(const Symbol &);
   void CheckBindCFunctionResult(const Symbol &);
   // Check functions for defined I/O procedures
   void CheckDefinedIoProc(
       const Symbol &, const GenericDetails &, common::DefinedIo);
if (type.category() == DeclTypeSpec::Character) {
     for (auto &parm : derived->parameters()) {
       Check(parm.second, canHaveAssumedTypeParameters);
     }
   }
 }
 
 void CheckHelper::Check(const Symbol &symbol) {
   if (symbol.name().size() > common::maxNameLen &&
-      &symbol == &symbol.GetUltimate() &&
-      !FindModuleFileContaining(symbol.owner())) {
-    messages_.Say(symbol.name(),
+      &symbol == &symbol.GetUltimate()) {
+    WarnIfNotInModuleFile(symbol.name(),
         "%s has length %d, which is greater than the maximum name length "
         "%d"_port_en_US,
         symbol.name(), symbol.name().size(), common::maxNameLen);
   }
   if (context_.HasError(symbol)) {
     return;
   }
   auto restorer{messages_.SetLocation(symbol.name())};
messages_.Say(
         "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
         symbol.name(), details.shape().Rank(), details.coshape().Rank(),
         common::maxRank);
   }
   CheckAssumedTypeEntity(symbol, details);
   WarnMissingFinal(symbol);
   const DeclTypeSpec *type{details.type()};
   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
+  bool isComponent{symbol.owner().IsDerivedType()};
   if (!details.coshape().empty()) {
     bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
     if (IsAllocatable(symbol)) {
       if (!isDeferredCoshape) { // C827
         messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
                       " coshape"_err_en_US,
             symbol.name());
       }
-    } else if (symbol.owner().IsDerivedType()) { // C746
+    } else if (isComponent) { // C746
       std::string deferredMsg{
           isDeferredCoshape ? "" : " and have a deferred coshape"};
       messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
                     " attribute%s"_err_en_US,
           symbol.name(), deferredMsg);
     } else {
       if (!details.coshape().CanBeAssumedSize()) { // C828
         messages_.Say(
if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
       if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
           details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
         messages_.Say(
             "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
       }
       if (IsPassedViaDescriptor(symbol)) {
         if (IsAllocatableOrPointer(symbol)) {
           if (inExplicitInterface) {
-            messages_.Say(
+            WarnIfNotInModuleFile(
                 "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
           } else {
             messages_.Say(
                 "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
           }
         } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
           if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
-            messages_.Say(
+            WarnIfNotInModuleFile(
                 "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
           } else if (inExplicitInterface) {
-            messages_.Say(
+            WarnIfNotInModuleFile(
                 "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
           } else {
             messages_.Say(
                 "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
           }
         }
       }
     }
if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
     CheckPointerInitialization(symbol);
     if (IsAutomatic(symbol)) {
       messages_.Say(
           "An automatic variable or component must not be initialized"_err_en_US);
     } else if (IsDummy(symbol)) {
       messages_.Say("A dummy argument must not be initialized"_err_en_US);
     } else if (IsFunctionResult(symbol)) {
       messages_.Say("A function result must not be initialized"_err_en_US);
-    } else if (IsInBlankCommon(symbol) &&
-        !FindModuleFileContaining(symbol.owner())) {
-      messages_.Say(
+    } else if (IsInBlankCommon(symbol)) {
+      WarnIfNotInModuleFile(
           "A variable in blank COMMON should not be initialized"_port_en_US);
     }
   }
   if (symbol.owner().kind() == Scope::Kind::BlockData) {
     if (IsAllocatable(symbol)) {
       messages_.Say(
           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
     } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
if (auto whyNot{
       }
     }
   }
   if (symbol.attrs().test(Attr::EXTERNAL)) {
     SayWithDeclaration(symbol,
         "'%s' is a data object and may not be EXTERNAL"_err_en_US,
         symbol.name());
   }
+
+  // Check CUDA attributes and special circumstances of being in device
+  // subprograms
+  const Scope &progUnit{GetProgramUnitContaining(symbol)};
+  const auto *subpDetails{!isComponent && progUnit.symbol()
+          ? progUnit.symbol()->detailsIf<SubprogramDetails>()
+          : nullptr};
+  bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
+  if (inDeviceSubprogram) {
+    if (IsSaved(symbol)) {
+      WarnIfNotInModuleFile(
+          "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
+          symbol.name());
+    }
+    if (IsPointer(symbol)) {
+      WarnIfNotInModuleFile(
+          "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
+          symbol.name());
+    }
+    if (details.isDummy() &&
+        details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
+            common::CUDADataAttr::Device &&
+        details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
+            common::CUDADataAttr::Managed) {
+      WarnIfNotInModuleFile(
+          "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
+          symbol.name(),
+          parser::ToUpperCaseLetters(
+              common::EnumToString(*details.cudaDataAttr())));
+    }
+  }
+  if (details.cudaDataAttr()) {
+    if (auto dyType{evaluate::DynamicType::From(symbol)}) {
+      if (dyType->category() != TypeCategory::Derived) {
+        if (!IsCUDAIntrinsicType(*dyType)) {
+          messages_.Say(
+              "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
+              symbol.name(), dyType->AsFortran());
+        }
+      }
+    }
+    auto attr{*details.cudaDataAttr()};
+    switch (attr) {
+    case common::CUDADataAttr::Constant:
+      if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
+            symbol.name());
+      } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
+                 !shape ||
+                 !evaluate::AsConstantExtents(foldingContext_, *shape)) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
+            symbol.name());
+      }
+      break;
+    case common::CUDADataAttr::Device:
+      if (isComponent && !IsAllocatable(symbol)) {
+        messages_.Say(
+            "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable"_err_en_US,
+            symbol.name());
+      }
+      break;
+    case common::CUDADataAttr::Managed:
+      if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
+          !details.isDummy()) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument"_err_en_US,
+            symbol.name());
+      }
+      break;
+    case common::CUDADataAttr::Pinned:
+      if (inDeviceSubprogram) {
+        WarnIfNotInModuleFile(
+            "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
+            symbol.name());
+      } else if (IsPointer(symbol)) {
+        WarnIfNotInModuleFile(
+            "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
+            symbol.name());
+      } else if (!IsAllocatable(symbol)) {
+        WarnIfNotInModuleFile(
+            "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
+            symbol.name());
+      }
+      break;
+    case common::CUDADataAttr::Shared:
+      if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
+            symbol.name());
+      } else if (!inDeviceSubprogram) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
+            symbol.name());
+      }
+      break;
+    case common::CUDADataAttr::Texture:
+      messages_.Say(
+          "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
+      break;
+    }
+    if (attr != common::CUDADataAttr::Pinned) {
+      if (details.commonBlock()) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
+            symbol.name(),
+            parser::ToUpperCaseLetters(common::EnumToString(attr)));
+      } else if (FindEquivalenceSet(symbol)) {
+        messages_.Say(
+            "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
+            symbol.name(),
+            parser::ToUpperCaseLetters(common::EnumToString(attr)));
+      }
+    }
+    if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
+        !inDeviceSubprogram && !IsAllocatable(symbol) &&
+        attr == common::CUDADataAttr::Device) {
+      messages_.Say(
+          "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
+          symbol.name(),
+          parser::ToUpperCaseLetters(common::EnumToString(attr)));
+    }
+    if (isComponent) {
+      if (attr == common::CUDADataAttr::Device) {
+        const DeclTypeSpec *type{symbol.GetType()};
+        if (const DerivedTypeSpec *
+            derived{type ? type->AsDerived() : nullptr}) {
+          DirectComponentIterator directs{*derived};
+          if (auto iter{std::find_if(directs.begin(), directs.end(),
+                  [](const Symbol &) { return false; })}) {
+            messages_.Say(
+                "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
+                symbol.name(), iter.BuildResultDesignatorName());
+          }
+        }
+      } else if (attr == common::CUDADataAttr::Constant ||
+          attr == common::CUDADataAttr::Shared) {
+        messages_.Say(
+            "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
+            symbol.name(),
+            parser::ToUpperCaseLetters(common::EnumToString(attr)));
+      }
+    } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
+        symbol.owner().kind() != Scope::Kind::MainProgram) {
+      messages_.Say(
+          "ATTRIBUTES(%s) may apply only to module, host subprogram, or device subprogram data"_err_en_US,
+          parser::ToUpperCaseLetters(common::EnumToString(attr)));
+    }
+  }
 }
 
 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
   if (IsPointer(symbol) && !context_.HasError(symbol) &&
       !scopeIsUninstantiatedPDT_) {
     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
       if (object->init()) { // C764, C765; C808
         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
if (arraySpec.Rank() == 0) {
     return;
   }
   bool isExplicit{arraySpec.IsExplicitShape()};
   bool canBeDeferred{arraySpec.CanBeDeferredShape()};
   bool canBeImplied{arraySpec.CanBeImpliedShape()};
   bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
   bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
   bool isAssumedRank{arraySpec.IsAssumedRank()};
+  bool isCUDAShared{
+      GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
+      common::CUDADataAttr::Shared};
   std::optional<parser::MessageFixedText> msg;
   if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit &&
       !canBeAssumedSize) {
     msg = "Cray pointee '%s' must have explicit shape or"
           " assumed size"_err_en_US;
   } else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
       !isAssumedRank) {
     if (symbol.owner().IsDerivedType()) { // C745
if (symbol.owner().IsDerivedType()) { // C745
       }
     }
   } else if (IsDummy(symbol)) {
     if (canBeImplied && !canBeAssumedSize) { // C836
       msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
     }
   } else if (canBeAssumedShape && !canBeDeferred) {
     msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
-  } else if (canBeAssumedSize && !canBeImplied) { // C833
+  } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared) { // C833
     msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
   } else if (isAssumedRank) { // C837
     msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
   } else if (canBeImplied) {
-    if (!IsNamedConstant(symbol)) { // C835, C836
+    if (!IsNamedConstant(symbol) && !isCUDAShared) { // C835, C836
       msg = "Implied-shape array '%s' must be a named constant or a "
             "dummy argument"_err_en_US;
     }
   } else if (IsNamedConstant(symbol)) {
     if (!isExplicit && !canBeImplied) {
       msg = "Named constant '%s' array must have constant or"
             " implied shape"_err_en_US;
     }
if (details.isInterface()) {
     if (!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);
     }
   }
   CheckExternal(symbol);
   CheckModuleProcedureDef(symbol);
+  auto cudaAttrs{details.cudaSubprogramAttrs()};
+  if (cudaAttrs &&
+      (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
+          *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
+      details.isFunction()) {
+    messages_.Say(symbol.name(),
+        "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
+  }
+  if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
+    // CUDA device subprogram checks
+    if (symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
+      messages_.Say(symbol.name(),
+          "A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
+    }
+    if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
+      messages_.Say(symbol.name(),
+          "A device subprogram may not be an internal subprogram"_err_en_US);
+    } else if ((*cudaAttrs == common::CUDASubprogramAttrs::Device ||
+                   *cudaAttrs == common::CUDASubprogramAttrs::HostDevice) &&
+        (symbol.owner().kind() != Scope::Kind::Module ||
+            details.isInterface())) {
+      messages_.Say(symbol.name(),
+          "An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure"_err_en_US);
+    }
+  }
+  if ((!details.cudaLaunchBounds().empty() ||
+          !details.cudaClusterDims().empty()) &&
+      !(cudaAttrs &&
+          (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
+              *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
+    messages_.Say(symbol.name(),
+        "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
+  }
+  if (!IsStmtFunction(symbol)) {
+    if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
+        outerDevice && outerDevice->symbol()) {
+      if (auto *msg{messages_.Say(symbol.name(),
+              "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
+              symbol.name(), outerDevice->symbol()->name())}) {
+        msg->Attach(outerDevice->symbol()->name(),
+            "Containing CUDA device subprogram"_en_US);
+      }
+    }
+  }
 }
 
 void CheckHelper::CheckExternal(const Symbol &symbol) {
   if (IsExternal(symbol)) {
     std::string interfaceName{symbol.name().ToString()};
     if (const auto *bind{symbol.GetBindName()}) {
       interfaceName = *bind;
     }
if (const Symbol * global{FindGlobal(symbol)};
                 "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_err_en_US,
                 global->name(), symbol.name());
           }
         } else if (auto chars{Characterize(symbol)}) {
           if (auto globalChars{Characterize(*global)}) {
             if (chars->HasExplicitInterface()) {
               std::string whyNot;
               if (!chars->IsCompatibleWith(*globalChars, &whyNot)) {
-                msg = messages_.Say(
+                msg = WarnIfNotInModuleFile(
                     "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
                     global->name(), whyNot);
               }
             } else if (!globalChars->CanBeCalledViaImplicitInterface()) {
               msg = messages_.Say(
                   "The global subprogram '%s' may not be referenced via the implicit interface '%s'"_err_en_US,
                   global->name(), symbol.name());
             }
if (const Symbol * global{FindGlobal(symbol)};
       }
     } else if (auto iter{externalNames_.find(interfaceName)};
                iter != externalNames_.end()) {
       const Symbol &previous{*iter->second};
       if (auto chars{Characterize(symbol)}) {
         if (auto previousChars{Characterize(previous)}) {
           std::string whyNot;
           if (!chars->IsCompatibleWith(*previousChars, &whyNot)) {
-            if (auto *msg{messages_.Say(
+            if (auto *msg{WarnIfNotInModuleFile(
                     "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
                     symbol.name(), whyNot)}) {
               evaluate::AttachDeclaration(msg, previous);
               evaluate::AttachDeclaration(msg, symbol);
             }
           }
         }
       }
bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
   } 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;
   } else {
     return true; // OK
   }
   bool isFatal{msg->IsFatal()};
+  if (isFatal || !FindModuleFileContaining(specific.owner())) {
     SayWithDeclaration(
         specific, std::move(*msg), MakeOpName(opName), specific.name());
+  }
   if (isFatal) {
     context_.SetError(specific);
   }
-  return false;
+  return !isFatal;
 }
 
 // If the number of arguments is wrong for this intrinsic operator, return
 // false and return the error message in msg.
 std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
     const GenericKind &kind, std::size_t nargs) {
   if (!kind.IsIntrinsicOperator()) {
     if (nargs < 1 || nargs > 2) {
bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
   std::optional<parser::MessageFixedText> msg;
   if (arg.IsOptional()) {
     msg = "In %s function '%s', dummy argument '%s' may not be"
           " OPTIONAL"_err_en_US;
   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
              dataObject == nullptr) {
     msg = "In %s function '%s', dummy argument '%s' must be a"
           " data object"_err_en_US;
+  } else if (dataObject->intent == common::Intent::Out) {
+    msg =
+        "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
   } else if (dataObject->intent != common::Intent::In &&
       !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
-    msg = "In %s function '%s', dummy argument '%s' must have INTENT(IN)"
-          " or VALUE attribute"_err_en_US;
+    msg =
+        "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
   }
   if (msg) {
+    bool isFatal{msg->IsFatal()};
+    if (isFatal || !FindModuleFileContaining(symbol.owner())) {
       SayWithDeclaration(symbol, std::move(*msg),
-        parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
+          parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
+          arg.name);
+    }
+    if (isFatal) {
       return false;
     }
+  }
   return true;
 }
 
 // Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
 bool CheckHelper::CheckDefinedAssignment(
     const Symbol &specific, const Procedure &proc) {
   if (context_.HasError(specific)) {
     return false;

 bool CheckHelper::CheckDefinedAssignmentArg(
     const Symbol &symbol, const DummyArgument &arg, int pos) {
   std::optional<parser::MessageFixedText> msg;
   if (arg.IsOptional()) {
     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
           " may not be OPTIONAL"_err_en_US;
   } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
     if (pos == 0) {
-      if (dataObject->intent != common::Intent::Out &&
+      if (dataObject->intent == common::Intent::In) {
+        msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
+              " may not have INTENT(IN)"_err_en_US;
+      } else if (dataObject->intent != common::Intent::Out &&
           dataObject->intent != common::Intent::InOut) {
         msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
-              " must have INTENT(OUT) or INTENT(INOUT)"_err_en_US;
+              " should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
       }
     } else if (pos == 1) {
-      if (dataObject->intent != common::Intent::In &&
+      if (dataObject->intent == common::Intent::Out) {
+        msg = "In defined assignment subroutine '%s', second dummy"
+              " argument '%s' may not have INTENT(OUT)"_err_en_US;
+      } else if (dataObject->intent != common::Intent::In &&
           !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
         msg =
             "In defined assignment subroutine '%s', second dummy"
-            " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US;
+            " argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
       } else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
         msg =
             "In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
       } else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
         msg =
             "In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
       }
     } else {
       DIE("pos must be 0 or 1");
     }
   } else {
     msg = "In defined assignment subroutine '%s', dummy argument '%s'"
           " must be a data object"_err_en_US;
   }
   if (msg) {
+    bool isFatal{msg->IsFatal()};
+    if (isFatal || !FindModuleFileContaining(symbol.owner())) {
       SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
+    }
+    if (isFatal) {
       context_.SetError(symbol);
       return false;
     }
+  }
   return true;
 }
 
 // Report a conflicting attribute error if symbol has both of these attributes
 bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
   if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
     messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
         symbol.name(), AttrToString(a1), AttrToString(a2));
void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
   const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
   int rank{object->shape().Rank()};
   const Symbol *initialDerivedSym{derivedSym};
   while (const auto *derivedDetails{
       derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
     if (!derivedDetails->finals().empty() &&
         !derivedDetails->GetFinalForRank(rank)) {
       if (auto *msg{derivedSym == initialDerivedSym
-                  ? messages_.Say(symbol.name(),
+                  ? WarnIfNotInModuleFile(symbol.name(),
                         "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
                         symbol.name(), derivedSym->name(), rank)
-                  : messages_.Say(symbol.name(),
+                  : WarnIfNotInModuleFile(symbol.name(),
                         "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
                         symbol.name(), initialDerivedSym->name(),
                         derivedSym->name(), rank)}) {
         msg->Attach(derivedSym->name(),
             "Declaration of derived type '%s'"_en_US, derivedSym->name());
       }
       return;
     }
if (const auto *type{symbol.GetType()}) {
         context_.SetError(symbol);
       }
       if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) {
         // ok
       } else if (IsAllocatableOrPointer(symbol) &&
           type->category() == DeclTypeSpec::Character &&
           type->characterTypeSpec().length().isDeferred()) {
         // ok; F'2018 18.3.6 p2(6)
-      } else if (derived || IsInteroperableIntrinsicType(*type)) {
+      } else if (derived ||
+          IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
         // F'2018 18.3.6 p2(4,5)
-      } else if (type->category() == DeclTypeSpec::Logical && IsDummy(symbol) &&
-          evaluate::GetRank(*shape) == 0) {
-        // Special exception: LOGICAL scalar dummy arguments can be converted
-        // before a call -- & after if not INTENT(IN) -- without loss of
-        // information, and are accepted by some older compilers.
-        messages_.Say(symbol.name(),
+      } else if (type->category() == DeclTypeSpec::Logical) {
+        if (IsDummy(symbol)) {
+          WarnIfNotInModuleFile(symbol.name(),
               "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
+        } else {
+          WarnIfNotInModuleFile(symbol.name(),
+              "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
+        }
       } else if (symbol.attrs().test(Attr::VALUE)) {
         messages_.Say(symbol.name(),
             "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
         context_.SetError(symbol);
       } else {
         messages_.Say(symbol.name(),
             "A BIND(C) object must have an interoperable type"_err_en_US);
         context_.SetError(symbol);
       }
     }
     if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
-      messages_.Say(symbol.name(),
+      WarnIfNotInModuleFile(symbol.name(),
           "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
     }
   } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
-    if (!proc->procInterface() ||
-        !proc->procInterface()->attrs().test(Attr::BIND_C)) {
+    if (!proc->isDummy() &&
+        (!proc->procInterface() ||
+            !proc->procInterface()->attrs().test(Attr::BIND_C))) {
       messages_.Say(symbol.name(),
           "An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement"_err_en_US);
       context_.SetError(symbol);
     }
   } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
     for (const Symbol *dummy : subp->dummyArgs()) {
       if (dummy) {
         CheckBindC(*dummy);
if (derived->sequence()) { // C1801
               if (auto *msg{messages_.Say(component->name(),
                       "Component '%s' of an interoperable derived type must have the BIND attribute"_err_en_US,
                       component->name())}) {
                 msg->Attach(derived->typeSymbol().name(),
                     "Non-interoperable component type"_en_US);
               }
               context_.SetError(symbol);
             }
-          } else if (!IsInteroperableIntrinsicType(*type)) {
+          } else if (!IsInteroperableIntrinsicType(
+                         *type, context_.languageFeatures())) {
+            auto maybeDyType{evaluate::DynamicType::From(*type)};
+            if (type->category() == DeclTypeSpec::Logical) {
+              WarnIfNotInModuleFile(component->name(),
+                  "A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL"_port_en_US);
+            } else if (type->category() == DeclTypeSpec::Character &&
+                maybeDyType && maybeDyType->kind() == 1) {
+              WarnIfNotInModuleFile(component->name(),
+                  "A CHARACTER component of a BIND(C) type should have length 1"_port_en_US);
+            } else {
               messages_.Say(component->name(),
                   "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
               context_.SetError(symbol);
             }
           }
+        }
         if (auto extents{
                 evaluate::GetConstantExtents(foldingContext_, component)};
             extents && evaluate::GetSize(*extents) == 0) {
           messages_.Say(component->name(),
               "An array component of an interoperable type must have at least one element"_err_en_US);
           context_.SetError(symbol);
         }
       }
     }
-    if (derived->componentNames().empty() &&
-        !FindModuleFileContaining(symbol.owner())) { // C1805
-      messages_.Say(symbol.name(),
+    if (derived->componentNames().empty()) { // C1805
+      WarnIfNotInModuleFile(symbol.name(),
           "A derived type with the BIND attribute is empty"_port_en_US);
     }
   }
 }
 
 bool CheckHelper::CheckDioDummyIsData(
     const Symbol &subp, const Symbol *arg, std::size_t position) {
   if (arg && arg->detailsIf<ObjectEntityDetails>()) {

flang/lib/Semantics/type.cpp

case ClassStar:
     return "CLASS(*)";
   }
 }
 
 llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {
   return o << x.AsFortran();
 }
 
-bool IsInteroperableIntrinsicType(const DeclTypeSpec &type) {
+bool IsInteroperableIntrinsicType(
+    const DeclTypeSpec &type, const common::LanguageFeatureControl &features) {
   auto dyType{evaluate::DynamicType::From(type)};
-  return dyType && IsInteroperableIntrinsicType(*dyType);
+  return dyType && IsInteroperableIntrinsicType(*dyType, &features);
 }
 
 } // namespace Fortran::semantics

flang/module/__cuda_builtins.f90

+!===-- module/__cuda_builtins.f90 ------------------------------------------===!
+!
+! 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
+!
+!===------------------------------------------------------------------------===!
+
+! These CUDA predefined variables are automatically available in device
+! subprograms.
+
+module __CUDA_builtins
+  use __Fortran_builtins, only: &
+    threadIdx => __builtin_threadIdx, &
+    blockDim => __builtin_blockDim, &
+    blockIdx => __builtin_blockIdx, &
+    gridDim => __builtin_gridDim, &
+    warpsize => __builtin_warpsize
+end module

flang/test/Semantics/bind-c06.f90

program main
 
   type, bind(c) :: t9
     !ERROR: Component 'y' of an interoperable derived type must have the BIND attribute
     type(t8) :: y
     integer :: z
   end type
 
   type, bind(c) :: t10
-    !ERROR: Each component of an interoperable derived type must have an interoperable type
+    !WARNING: A CHARACTER component of a BIND(C) type should have length 1
     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
+    !PORTABILITY: A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL
     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
   type, bind(c) :: t15
     !ERROR: An array component of an interoperable type must have at least one element
     real :: x(0)
   end type
 
 end

flang/test/Semantics/cuf02.cuf

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  interface
+    !ERROR: An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure
+    attributes(device) subroutine exts1
+    end
+  end interface
+ contains
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  recursive attributes(device) subroutine s1
+  end
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  pure attributes(device) subroutine s2
+  end
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  elemental attributes(device) subroutine s3
+  end
+  subroutine s4
+   contains
+    !ERROR: A device subprogram may not be an internal subprogram
+    attributes(device) subroutine inner
+    end
+  end
+  attributes(device) subroutine s5 ! nvfortran crashes on this one
+   contains
+    !ERROR: 'inner' may not be an internal procedure of CUDA device subprogram 's5'
+    subroutine inner
+    end
+  end
+  attributes(device) subroutine s6
+    stmtfunc(x) = x + 1. ! ok
+  end
+  !ERROR: A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+  attributes(global) real function f1
+  end
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  recursive attributes(global) subroutine s7
+  end
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  pure attributes(global) subroutine s8
+  end
+  !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+  elemental attributes(global) subroutine s9
+  end
+end
+
+!ERROR: An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure
+attributes(device) subroutine exts1
+end

flang/test/Semantics/cuf03.cuf

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Exercise CUDA data attribute checks
+module m
+  real, constant :: mc ! ok
+  real, constant :: mci = 1. ! ok
+  !ERROR: Object 'mcl' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+  real, constant, allocatable :: mcl
+  !ERROR: Object 'mcp' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+  real, constant, pointer :: mcp
+  !ERROR: Object 'mct' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+  real, constant, target :: mct
+  real, device :: md ! ok
+  real, device :: mdi = 1.
+  real, device, allocatable :: mdl ! ok
+  real, device, pointer :: mdp ! ok at module level
+  real, device, target :: mdt ! ok
+  !ERROR: Object 'ms' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+  real, shared :: ms
+  !ERROR: Object 'msi' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+  real, shared :: msi = 1.
+  !ERROR: Object 'msl' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+  real, shared, allocatable :: msl
+  !ERROR: Object 'msp' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+  real, shared, pointer :: msp
+  !ERROR: Object 'mst' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+  real, shared, target :: mst
+  !ERROR: Object 'msa' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+  real, shared :: msa(*)
+  !ERROR: Object 'mm' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+  real, managed :: mm
+  !ERROR: Object 'mmi' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+  real, managed :: mmi = 1.
+  real, managed, allocatable :: mml ! ok
+  !ERROR: Object 'mmp' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+  real, managed, pointer :: mmp ! ok
+  !ERROR: Object 'mmt' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+  real, managed, target :: mmt
+  !WARNING: Object 'mp' with ATTRIBUTES(PINNED) should also be allocatable
+  real, pinned :: mp
+  !WARNING: Object 'mpi' with ATTRIBUTES(PINNED) should also be allocatable
+  real, pinned :: mpi = 1.
+  real, pinned, allocatable :: mpl ! ok
+  !ERROR: Object 'mpp' with ATTRIBUTES(PINNED) may not be a pointer
+  real, pinned, pointer :: mpp
+  !WARNING: Object 'mpt' with ATTRIBUTES(PINNED) should also be allocatable
+  real, pinned, target :: mpt ! ok
+  !ERROR: ATTRIBUTES(TEXTURE) is obsolete and no longer supported
+  real, texture, pointer :: mt
+  !ERROR: 'bigint' has intrinsic type 'INTEGER(16)' that is not available on the device
+  integer(16), device :: bigint
+ contains
+  attributes(device) subroutine devsubr(n,da)
+    integer, intent(in) :: n
+    real, device :: da(*) ! ok
+    real, managed :: ma(n) ! ok
+    !WARNING: Pointer 'dp' may not be associated in a device subprogram
+    real, device, pointer :: dp
+  end subroutine
+end module

flang/test/Semantics/cuf08.cuf

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ contains
+  !ERROR: A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+  launch_bounds(1,2) subroutine bad1; end
+  !ERROR: A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+  cluster_dims(1,2,3) subroutine bad2; end
+  attributes(global) launch_bounds(1,2) subroutine good1; end
+  attributes(global) launch_bounds(1,2,3) subroutine good2; end
+  !ERROR: LAUNCH_BOUNDS() may only appear once
+  attributes(global) launch_bounds(1,2) launch_bounds(3,4) subroutine bad3; end
+  !ERROR: Operands of LAUNCH_BOUNDS() must be 2 or 3 integer constants
+  attributes(global) launch_bounds(1) subroutine bad4; end
+  !ERROR: Operands of LAUNCH_BOUNDS() must be 2 or 3 integer constants
+  attributes(global) launch_bounds(1,2,3,4) subroutine bad5; end
+  attributes(global) cluster_dims(1,2,3) subroutine good3; end
+  !ERROR: CLUSTER_DIMS() may only appear once
+  attributes(global) cluster_dims(1,2,3) cluster_dims(4,5,6) subroutine bad6; end
+  !ERROR: Operands of CLUSTER_DIMS() must be three integer constants
+  attributes(global) cluster_dims(1) subroutine bad7; end
+  !ERROR: Operands of CLUSTER_DIMS() must be three integer constants
+  attributes(global) cluster_dims(1,2,3,4) subroutine bad8; end
+end module

flang/test/Semantics/resolve65.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Test restrictions on what subprograms can be used for defined assignment.
 
 module m1
   implicit none
   type :: t
   contains
+    !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t4' and 't%assign_t5' as their interfaces are not distinguishable
+    !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t4' and 't%assign_t6' as their interfaces are not distinguishable
+    !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t5' and 't%assign_t6' as their interfaces are not distinguishable
     !ERROR: Defined assignment procedure 'binding' must be a subroutine
     generic :: assignment(=) => binding
     procedure :: binding => assign_t1
     procedure :: assign_t
     procedure :: assign_t2
     procedure :: assign_t3
     !ERROR: Defined assignment subroutine 'assign_t2' must have two dummy arguments
-    !ERROR: In defined assignment subroutine 'assign_t3', second dummy argument 'y' must have INTENT(IN) or VALUE attribute
-    !ERROR: In defined assignment subroutine 'assign_t4', first dummy argument 'x' must have INTENT(OUT) or INTENT(INOUT)
-    generic :: assignment(=) => assign_t, assign_t2, assign_t3, assign_t4
+    !WARNING: In defined assignment subroutine 'assign_t3', second dummy argument 'y' should have INTENT(IN) or VALUE attribute
+    !WARNING: In defined assignment subroutine 'assign_t4', first dummy argument 'x' should have INTENT(OUT) or INTENT(INOUT)
+    !ERROR: In defined assignment subroutine 'assign_t5', first dummy argument 'x' may not have INTENT(IN)
+    !ERROR: In defined assignment subroutine 'assign_t6', second dummy argument 'y' may not have INTENT(OUT)
+    generic :: assignment(=) => assign_t, assign_t2, assign_t3, assign_t4, assign_t5, assign_t6
     procedure :: assign_t4
+    procedure :: assign_t5
+    procedure :: assign_t6
   end type
   type :: t2
   contains
     procedure, nopass :: assign_t
     !ERROR: Defined assignment procedure 'assign_t' may not have NOPASS attribute
     generic :: assignment(=) => assign_t
   end type
 contains
subroutine assign_t2(x)
     class(t), intent(out) :: x
   end
   subroutine assign_t3(x, y)
     class(t), intent(out) :: x
     real :: y
   end
   subroutine assign_t4(x, y)
     class(t) :: x
-      integer, intent(in) :: y
   end
+  subroutine assign_t5(x, y)
+    class(t), intent(in) :: x
+    integer, intent(in) :: y
+  end
+  subroutine assign_t6(x, y)
+    class(t), intent(out) :: x
+    integer, intent(out) :: y
+  end
 end
 
 module m2
   type :: t
   end type
   !ERROR: Generic 'assignment(=)' may not have specific procedures 's3' and 's4' as their interfaces are not distinguishable
   interface assignment(=)
     !ERROR: In defined assignment subroutine 's1', dummy argument 'y' may not be OPTIONAL

flang/test/Semantics/resolve67.f90

 module m3
   interface operator(/)
     !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
+    !WARNING: In OPERATOR(<) function 'lt1', dummy argument 'x' should 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 'x' may not be INTENT(OUT)
     !ERROR: In OPERATOR(<) function 'lt2', dummy argument 'y' must be a data object
     logical function lt2(x, y)
-      logical, intent(in) :: x
+      logical, intent(out) :: x
       intent(in) :: y
       interface
         subroutine y()
         end
       end interface
     end
   end interface
  contains