[flang] Warn about dangerous TRANSFER()

[klausler]

Summary

When the source or mold of a reference to the intrinsic function TRANSFER()
has a derived type with a direct component that contains a descriptor,
such as an allocatable or a pointer, emit a warning. User programs
should never access descriptors directly.

flang/lib/Evaluate/intrinsics.cpp

static bool CheckAtomicDefineAndRef(FoldingContext &context,
   }
 
   return sameType &&
       CheckForCoindexedObject(context, statArg, procName, "stat");
 }
 
 // Applies any semantic checks peculiar to an intrinsic.
 // TODO: Move the rest of these checks to Semantics/check-call.cpp, which is
-// where ASSOCIATED() is now validated.
+// where ASSOCIATED() and TRANSFER() are now validated.
 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {
     const auto &arg{call.arguments[0]};
     if (arg) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         ok = evaluate::IsAllocatableDesignator(*expr);
if (!arrayType || !procChars) {
                       characteristics::DummyDataObject::Attr::Target)) {
             ok = false;
             context.messages().Say(at,
                 "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute"_err_en_US);
           }
         }
       }
     }
-  } else if (name == "transfer") { // 16.9.193
-    if (call.arguments.size() >= 2) {
-      auto source{characteristics::TypeAndShape::Characterize(
-          call.arguments[0], context)};
-      auto mold{characteristics::TypeAndShape::Characterize(
-          call.arguments[1], context)};
-      if (source && mold && mold->Rank() > 0 &&
-          evaluate::ToInt64(
-              evaluate::Fold(
-                  context, mold->MeasureElementSizeInBytes(context, false)))
-                  .value_or(1) == 0) {
-        if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(
-                context, source->MeasureSizeInBytes(context)))}) {
-          if (*sourceSize > 0) {
-            context.messages().Say(
-                "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
-            ok = false;
-          }
-        } else {
-          context.messages().Say(
-              "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
-        }
-      }
-      if (call.arguments.size() > 2) {
-        if (const Symbol *whole{
-                UnwrapWholeSymbolOrComponentDataRef(call.arguments[2])}) {
-          if (IsOptional(*whole)) {
-            context.messages().Say(
-                "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,
-                whole->name());
-            ok = false;
-          } else if (IsAllocatableOrPointer(*whole)) {
-            context.messages().Say(
-                "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
-          }
-        }
-      }
-    }
   } else if (name == "ucobound") {
     return CheckDimAgainstCorank(call, context);
   }
   return ok;
 }
 
 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
     const common::IntrinsicTypeDefaultKinds &defaults) {

flang/lib/Semantics/check-call.cpp

if (const auto &pointerArg{arguments[0]}) {
     ok = false;
   }
   if (!ok) {
     context.messages().Say(
         "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
   }
 }
 
+// TRANSFER (16.9.193)
+static void CheckTransferOperandType(parser::ContextualMessages &messages,
+    const evaluate::DynamicType &type, const char *which) {
+  if (type.IsPolymorphic()) {
+    messages.Say("%s of TRANSFER is polymorphic"_warn_en_US, which);
+  } else if (!type.IsUnlimitedPolymorphic() &&
+      type.category() == TypeCategory::Derived) {
+    DirectComponentIterator directs{type.GetDerivedTypeSpec()};
+    if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};
+        bad != directs.end()) {
+      evaluate::SayWithDeclaration(messages, *bad,
+          "%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,
+          which, bad.BuildResultDesignatorName());
+    }
+  }
+}
+
+static void CheckTransfer(evaluate::ActualArguments &arguments,
+    evaluate::FoldingContext &context, const Scope *scope) {
+  if (arguments.size() >= 2) {
+    if (auto source{characteristics::TypeAndShape::Characterize(
+            arguments[0], context)}) {
+      CheckTransferOperandType(context.messages(), source->type(), "Source");
+      if (auto mold{characteristics::TypeAndShape::Characterize(
+              arguments[1], context)}) {
+        CheckTransferOperandType(context.messages(), mold->type(), "Mold");
+        if (mold->Rank() > 0 &&
+            evaluate::ToInt64(
+                evaluate::Fold(
+                    context, mold->MeasureElementSizeInBytes(context, false)))
+                    .value_or(1) == 0) {
+          if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(
+                  context, source->MeasureSizeInBytes(context)))}) {
+            if (*sourceSize > 0) {
+              context.messages().Say(
+                  "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
+            }
+          } else {
+            context.messages().Say(
+                "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
+          }
+        }
+      }
+    }
+    if (arguments.size() > 2) { // SIZE=
+      if (const Symbol *
+          whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) {
+        if (IsOptional(*whole)) {
+          context.messages().Say(
+              "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,
+              whole->name());
+        } else if (IsAllocatableOrPointer(*whole)) {
+          context.messages().Say(
+              "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
+        }
+      }
+    }
+  }
+}
+
 static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
     evaluate::FoldingContext &context, const Scope *scope,
     const evaluate::SpecificIntrinsic &intrinsic) {
   if (intrinsic.name == "associated") {
     CheckAssociated(arguments, context, scope);
+  } else if (intrinsic.name == "transfer") {
+    CheckTransfer(arguments, context, scope);
   }
 }
 
 static parser::Messages CheckExplicitInterface(
     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
     const evaluate::FoldingContext &context, const Scope *scope,
     const evaluate::SpecificIntrinsic *intrinsic,
     bool allowActualArgumentConversions) {

flang/test/Semantics/transfer01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Check errors in TRANSFER()
 
 subroutine subr(o)
   integer, intent(in), optional :: o
   type empty
   end type
   type(empty) :: empty1(1)
+  type hasdescriptor
+    real, allocatable :: allocatable
+  end type
+  type(hasdescriptor) hasDesc
   real :: empty2(0)
   character(0) :: empty3(1)
   integer, pointer :: source(:)
   integer, allocatable :: ia
   integer, pointer :: ip
   !ERROR: Element size of MOLD= array may not be zero when SOURCE= is not empty
   print *, transfer(1., empty1)
   print *, transfer(1., empty2) ! ok
   !ERROR: Element size of MOLD= array may not be zero when SOURCE= is not empty
   print *, transfer(1., empty3)
   !WARNING: Element size of MOLD= array may not be zero unless SOURCE= is empty
   print *, transfer(source, empty1)
   print *, transfer(source, empty2) ! ok
   !WARNING: Element size of MOLD= array may not be zero unless SOURCE= is empty
   print *, transfer(source, empty3)
   !ERROR: SIZE= argument may not be the optional dummy argument 'o'
   print *, transfer(1., empty2, size=o)
   !WARNING: SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning
   print *, transfer(1., empty2, size=ia)
   !WARNING: SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning
   print *, transfer(1., empty2, size=ip)
+  !WARNING: Source of TRANSFER contains allocatable or pointer component %allocatable
+  print *, transfer(hasDesc, 1)
 end
-