https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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.
(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.)
>From a66830b9f3ac8346a7d3b98bee690599728e8866 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 31 Oct 2023 16:09:36 -0700
Subject: [PATCH] [flang] Allow polymorphic actual to implicit interface
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.
(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.)
---
flang/lib/Semantics/check-call.cpp | 8 ++++----
flang/test/Semantics/call13.f90 | 9 ++++-----
flang/test/Semantics/call40.f90 | 2 +-
flang/test/Semantics/label18.f90# | 18 ------------------
4 files changed, 9 insertions(+), 28 deletions(-)
delete mode 100644 flang/test/Semantics/label18.f90#
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