[flang] Allow polymorphic actual to implicit interface (#70873)

Semantics is emitting an error when an actual argument to a procedure that has an implicit interface has a polymorphic type. This is too general; while TYPE(*) and CLASS(*) unlimited polymorphic items require the presence of an explicit procedure interface, CLASS(T) data can be passed over an implicit interface to a procedure expecting a corresponding dummy argument with TYPE(T), so long as T is not parameterized. (Only XLF handles this usage correctly among other Fortran compilers.) (Making this work in the case of an actual CLASS(T) array may well require additional changes in lowering to copy data to/from a temporary buffer to ensure contiguity when the actual type of the array is an extension of T.)
llvm · Nov 13, 2023 · 29fd3e2 · 29fd3e2
1 parent c9626e6
commit 29fd3e2
Show file tree

Hide file tree

Showing 8 changed files with 38 additions and 44 deletions.
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
@@ -273,10 +273,10 @@ struct DummyArgument {
   ~DummyArgument();
   bool operator==(const DummyArgument &) const;
   bool operator!=(const DummyArgument &that) const { return !(*this == that); }
-  static std::optional<DummyArgument> FromActual(
-      std::string &&, const Expr<SomeType> &, FoldingContext &);
-  static std::optional<DummyArgument> FromActual(
-      std::string &&, const ActualArgument &, FoldingContext &);
+  static std::optional<DummyArgument> FromActual(std::string &&,
+      const Expr<SomeType> &, FoldingContext &, bool forImplicitInterface);
+  static std::optional<DummyArgument> FromActual(std::string &&,
+      const ActualArgument &, FoldingContext &, bool forImplicitInterface);
   bool IsOptional() const;
   void SetOptional(bool = true);
   common::Intent GetIntent() const;

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
@@ -792,8 +792,9 @@ static std::optional<DummyArgument> CharacterizeDummyArgument(
   return std::nullopt;
 }
 
-std::optional<DummyArgument> DummyArgument::FromActual(
-    std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
+std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
+    const Expr<SomeType> &expr, FoldingContext &context,
+    bool forImplicitInterface) {
   return common::visit(
       common::visitors{
           [&](const BOZLiteralConstant &) {
@@ -828,6 +829,13 @@ std::optional<DummyArgument> DummyArgument::FromActual(
           },
           [&](const auto &) {
             if (auto type{TypeAndShape::Characterize(expr, context)}) {
+              if (forImplicitInterface &&
+                  !type->type().IsUnlimitedPolymorphic() &&
+                  type->type().IsPolymorphic()) {
+                // Pass the monomorphic declared type to an implicit interface
+                type->set_type(DynamicType{
+                    type->type().GetDerivedTypeSpec(), /*poly=*/false});
+              }
               DummyDataObject obj{std::move(*type)};
               obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
               return std::make_optional<DummyArgument>(
@@ -840,10 +848,11 @@ std::optional<DummyArgument> DummyArgument::FromActual(
       expr.u);
 }
 
-std::optional<DummyArgument> DummyArgument::FromActual(
-    std::string &&name, const ActualArgument &arg, FoldingContext &context) {
+std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
+    const ActualArgument &arg, FoldingContext &context,
+    bool forImplicitInterface) {
   if (const auto *expr{arg.UnwrapExpr()}) {
-    return FromActual(std::move(name), *expr, context);
+    return FromActual(std::move(name), *expr, context, forImplicitInterface);
   } else if (arg.GetAssumedTypeDummy()) {
     return std::nullopt;
   } else {
@@ -1325,8 +1334,9 @@ std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
       for (const auto &arg : args) {
         ++j;
         if (arg) {
-          if (auto dummy{DummyArgument::FromActual(
-                  "x"s + std::to_string(j), *arg, context)}) {
+          if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j),
+                  *arg, context,
+                  /*forImplicitInterface=*/true)}) {
             callee->dummyArguments.emplace_back(std::move(*dummy));
             continue;
           }

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
@@ -2325,8 +2325,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
             }
           }
         }
-        if (auto dc{characteristics::DummyArgument::FromActual(
-                std::move(kw), *expr, context)}) {
+        if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw),
+                *expr, context, /*forImplicitInterface=*/false)}) {
           dummyArgs.emplace_back(std::move(*dc));
           if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
             sameDummyArg = j;

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
@@ -247,7 +247,8 @@ Fortran::lower::CallerInterface::characterize() const {
           std::optional<Fortran::evaluate::characteristics::DummyArgument>
               argCharacteristic =
                   Fortran::evaluate::characteristics::DummyArgument::FromActual(
-                      "actual", *expr, foldingContext);
+                      "actual", *expr, foldingContext,
+                      /*forImplicitInterface=*/true);
           assert(argCharacteristic &&
                  "failed to characterize argument in implicit call");
           characteristic->dummyArguments.emplace_back(

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
@@ -38,14 +38,14 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
   if (auto type{arg.GetType()}) {
     if (type->IsAssumedType()) {
       messages.Say(
-          "Assumed type argument requires an explicit interface"_err_en_US);
-    } else if (type->IsPolymorphic()) {
+          "Assumed type actual argument requires an explicit interface"_err_en_US);
+    } else if (type->IsUnlimitedPolymorphic()) {
       messages.Say(
-          "Polymorphic argument requires an explicit interface"_err_en_US);
+          "Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);
     } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
       if (!derived->parameters().empty()) {
         messages.Say(
-            "Parameterized derived type argument requires an explicit interface"_err_en_US);
+            "Parameterized derived type actual argument requires an explicit interface"_err_en_US);
       }
     }
   }
@@ -76,7 +76,8 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
             "VOLATILE argument requires an explicit interface"_err_en_US);
       }
     } else if (auto argChars{characteristics::DummyArgument::FromActual(
-                   "actual argument", *expr, context)}) {
+                   "actual argument", *expr, context,
+                   /*forImplicitInterface=*/true)}) {
       const auto *argProcDesignator{
           std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
       if (const auto *argProcSymbol{
@@ -913,7 +914,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
       }
     }
     if (auto argChars{characteristics::DummyArgument::FromActual(
-            "actual argument", *expr, foldingContext)}) {
+            "actual argument", *expr, foldingContext,
+            /*forImplicitInterface=*/true)}) {
       if (!argChars->IsTypelessIntrinsicDummy()) {
         if (auto *argProc{
                 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {

diff --git a/flang/test/Semantics/call13.f90 b/flang/test/Semantics/call13.f90
@@ -24,13 +24,12 @@ subroutine s(assumedRank, coarray, class, classStar, typeStar)
   call implicit11(assumedRank)  ! 15.4.2.2(3)(c)
   !ERROR: Coarray argument requires an explicit interface
   call implicit12(coarray)  ! 15.4.2.2(3)(d)
-  !ERROR: Parameterized derived type argument requires an explicit interface
+  !ERROR: Parameterized derived type actual argument requires an explicit interface
   call implicit13(pdtx)  ! 15.4.2.2(3)(e)
-  !ERROR: Polymorphic argument requires an explicit interface
-  call implicit14(class)  ! 15.4.2.2(3)(f)
-  !ERROR: Polymorphic argument requires an explicit interface
+  call implicit14(class)  ! ok
+  !ERROR: Unlimited polymorphic actual argument requires an explicit interface
   call implicit15(classStar)  ! 15.4.2.2(3)(f)
-  !ERROR: Assumed type argument requires an explicit interface
+  !ERROR: Assumed type actual argument requires an explicit interface
   call implicit16(typeStar)  ! 15.4.2.2(3)(f)
   !ERROR: TYPE(*) dummy argument may only be used as an actual argument
   if (typeStar) then

diff --git a/flang/test/Semantics/call40.f90 b/flang/test/Semantics/call40.f90
@@ -16,7 +16,7 @@ subroutine val_errors(array, string, polymorphic, derived)
   !ERROR: %VAL argument must be a scalar numerical or logical expression
   call foo3(%val(derived))
   !ERROR: %VAL argument must be a scalar numerical or logical expression
-  !ERROR: Assumed type argument requires an explicit interface
+  !ERROR: Assumed type actual argument requires an explicit interface
   call foo4(%val(polymorphic))
 end subroutine
 

diff --git a/flang/test/Semantics/label18.f90# b/flang/test/Semantics/label18.f90#