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

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

<details>
<summary>Changes</summary>

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.)

---
Full diff: https://github.com/llvm/llvm-project/pull/70873.diff


4 Files Affected:

- (modified) flang/lib/Semantics/check-call.cpp (+4-4) 
- (modified) flang/test/Semantics/call13.f90 (+4-5) 
- (modified) flang/test/Semantics/call40.f90 (+1-1) 
- (removed) flang/test/Semantics/label18.f90# (-18) 


``````````diff
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index bf80dbecab009d9..cd1f66f471aba57 100644
--- 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);
       }
     }
   }
diff --git a/flang/test/Semantics/call13.f90 b/flang/test/Semantics/call13.f90
index a5ef1ca34a66d16..8b203e4b715d50b 100644
--- 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
index 492fcdd1256af52..c248be6937e21b3 100644
--- 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#
deleted file mode 100644
index 47b2a61dbc4b5dc..000000000000000
--- a/flang/test/Semantics/label18.f90#
+++ /dev/null
@@ -1,18 +0,0 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
-program main
-  if (.true.) then
-    do j = 1, 2
-      goto 1 ! ok; used to cause looping in label resolution
-    end do
-  else
-    goto 1 ! ok
-1 end if
-  if (.true.) then
-    do j = 1, 2
-      !WARNING: Label '1' is in a construct that should not be used as a branch target here
-      goto 1
-    end do
-  end if
-  !WARNING: Label '1' is in a construct that should not be used as a branch target here
-  goto 1
-end

``````````

</details>


https://github.com/llvm/llvm-project/pull/70873