[flang] Check restrictions on TRANSFER()

[klausler]

Summary

Enforce detectable compilation-time violations of restrictions on the
arguments to the TRANSFER() intrinsic function (16.9.163) with
error messages, and mark other potential problems with warnings.

[clementval]

Semantics/transfer01.f90 is failing.

flang/include/flang/Evaluate/characteristics.h

static std::optional<TypeAndShape> Characterize(
     if (x) {
       return Characterize(*x, context);
     } else {
       return std::nullopt;
     }
   }
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      const A *p, FoldingContext &context) {
-    if (p) {
-      return Characterize(*p, context);
+      A *ptr, FoldingContext &context) {
+    if (ptr) {
+      return Characterize(std::as_const(*ptr), context);
     } else {
       return std::nullopt;
     }
   }
 
   DynamicType type() const { return type_; }
   TypeAndShape &set_type(DynamicType t) {
     type_ = t;

flang/include/flang/Evaluate/tools.h

if (!typeParam->base()) {
         }
       }
     }
   }
   return nullptr;
 }
 
 // If an expression simply wraps a DataRef, extract and return it.
-// The Boolean argument controls the handling of Substring and ComplexPart
+// The Boolean arguments control the handling of Substring and ComplexPart
 // references: when true (not default), it extracts the base DataRef
-// of a substring or complex part, if it has one.
+// of a substring or complex part.
 template <typename A>
 common::IfNoLvalue<std::optional<DataRef>, A> ExtractDataRef(
     const A &, bool intoSubstring, bool intoComplexPart) {
   return std::nullopt; // default base case
 }
 template <typename T>
 std::optional<DataRef> ExtractDataRef(const Designator<T> &d,
     bool intoSubstring = false, bool intoComplexPart = false) {

flang/lib/Evaluate/intrinsics.cpp

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

 static parser::Messages CheckExplicitInterface(
     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
     const evaluate::FoldingContext &context, const Scope *scope,
     const evaluate::SpecificIntrinsic *intrinsic,
     bool allowActualArgumentConversions) {
   parser::Messages buffer;
   parser::ContextualMessages messages{context.messages().at(), &buffer};
   RearrangeArguments(proc, actuals, messages);
+  evaluate::FoldingContext localContext{context, messages};
   if (buffer.empty()) {
     int index{0};
-    evaluate::FoldingContext localContext{context, messages};
     for (auto &actual : actuals) {
       const auto &dummy{proc.dummyArguments.at(index++)};
       if (actual) {
         CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope,
             intrinsic, allowActualArgumentConversions);
       } else if (!dummy.IsOptional()) {
         if (dummy.name.empty()) {
           messages.Say(

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)
+  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)
+end
+