[flang-commits] [flang] [flang] Derived type structural equivalence (PR #69376)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Oct 17 12:50:02 PDT 2023
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/69376
F'202X 7.5.2.4 describes conditions under which two derived type definitions are to be considered equivalent. These rules are already implemented in Evaluate/type.cpp but not exposed for general use; rearrange the code a little so that the compatibility checking of separate module procedure interfaces and explicit definitions can use it to avoid emitting a bogus error message.
Fixes https://github.com/llvm/llvm-project/issues/67946.
>From 97d80bf806ad9e3fb763673f1109b0b00d2f2a1e Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 17 Oct 2023 12:23:19 -0700
Subject: [PATCH] [flang] Derived type structural equivalence
F'202X 7.5.2.4 describes conditions under which two derived type
definitions are to be considered equivalent. These rules are
already implemented in Evaluate/type.cpp but not exposed for
general use; rearrange the code a little so that the compatibility
checking of separate module procedure interfaces and explicit
definitions can use it to avoid emitting a bogus error message.
Fixes https://github.com/llvm/llvm-project/issues/67946.
---
flang/include/flang/Evaluate/type.h | 4 +
flang/lib/Evaluate/type.cpp | 15 +++-
flang/lib/Semantics/check-declarations.cpp | 5 +-
flang/test/Semantics/separate-mp02.f90 | 10 +--
flang/test/Semantics/separate-mp03.f90 | 2 +-
flang/test/Semantics/separate-mp06.f90 | 98 ++++++++++++++++++++++
6 files changed, 124 insertions(+), 10 deletions(-)
create mode 100644 flang/test/Semantics/separate-mp06.f90
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 13060e42e47adbf..33b94ed31843cf6 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -207,6 +207,10 @@ class DynamicType {
// SAME_TYPE_AS (16.9.165); ignores type parameter values
std::optional<bool> SameTypeAs(const DynamicType &) const;
+ // 7.5.2.4 type equivalence; like operator==(), but SEQUENCE/BIND(C)
+ // derived types can be structurally equivalent.
+ bool IsEquivalentTo(const DynamicType &) const;
+
// Result will be missing when a symbol is absent or
// has an erroneous type, e.g., REAL(KIND=666).
static std::optional<DynamicType> From(const semantics::DeclTypeSpec &);
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index e5d9851e2496aeb..967a933375940e0 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -288,7 +288,7 @@ const semantics::DerivedTypeSpec *GetParentTypeSpec(
}
// Compares two derived type representations to see whether they both
-// represent the "same type" in the sense of section 7.5.2.4.
+// represent the "same type" in the sense of section F'2023 7.5.2.4.
using SetOfDerivedTypePairs =
std::set<std::pair<const semantics::DerivedTypeSpec *,
const semantics::DerivedTypeSpec *>>;
@@ -508,6 +508,19 @@ bool AreSameDerivedType(
return AreSameDerivedType(x, y, false, false, inProgress);
}
+bool AreSameDerivedType(
+ const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
+ return x == y || (x && y && AreSameDerivedType(*x, *y));
+}
+
+bool DynamicType::IsEquivalentTo(const DynamicType &that) const {
+ return category_ == that.category_ && kind_ == that.kind_ &&
+ PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
+ knownLength().has_value() == that.knownLength().has_value() &&
+ (!knownLength() || *knownLength() == *that.knownLength()) &&
+ AreSameDerivedType(derived_, that.derived_);
+}
+
static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
const semantics::DerivedTypeSpec *y, bool isPolymorphic,
bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2c2866d590ae5a4..ce16b2df54b050f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3354,10 +3354,9 @@ void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
const DummyDataObject &obj2) {
if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
} else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
- } else if (obj1.type.type() != obj2.type.type()) {
+ } else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
Say(symbol1, symbol2,
- "Dummy argument '%s' has type %s; the corresponding argument in the"
- " interface body has type %s"_err_en_US,
+ "Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
} else if (!ShapesAreCompatible(obj1, obj2)) {
Say(symbol1, symbol2,
diff --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90
index fd9c4c3cc18f98b..39a469b6ccc09e8 100644
--- a/flang/test/Semantics/separate-mp02.f90
+++ b/flang/test/Semantics/separate-mp02.f90
@@ -51,9 +51,9 @@ module subroutine s5(x, y)
real :: y
end
module subroutine s6(x, y)
- !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has type REAL(4)
+ !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has distinct type REAL(4)
integer :: x
- !ERROR: Dummy argument 'y' has type REAL(8); the corresponding argument in the interface body has type REAL(4)
+ !ERROR: Dummy argument 'y' has type REAL(8); the corresponding argument in the interface body has distinct type REAL(4)
real(8) :: y
end
module subroutine s7(x, y, z)
@@ -72,10 +72,10 @@ module subroutine s8(x, y, z)
end
module subroutine s9(x, y, z, w)
character(len=4) :: x
- !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=4_8)
+ !ERROR: Dummy argument 'y' has type CHARACTER(KIND=1,LEN=5_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=4_8)
character(len=5) :: y
character(len=*) :: z
- !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=*)
+ !ERROR: Dummy argument 'w' has type CHARACTER(KIND=1,LEN=4_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=*)
character(len=4) :: w
end
end
@@ -330,7 +330,7 @@ module subroutine sub1(s)
character(len=-1) s ! ok
end subroutine
module subroutine sub2(s)
- !ERROR: Dummy argument 's' has type CHARACTER(KIND=1,LEN=1_8); the corresponding argument in the interface body has type CHARACTER(KIND=1,LEN=0_8)
+ !ERROR: Dummy argument 's' has type CHARACTER(KIND=1,LEN=1_8); the corresponding argument in the interface body has distinct type CHARACTER(KIND=1,LEN=0_8)
character(len=1) s
end subroutine
end submodule
diff --git a/flang/test/Semantics/separate-mp03.f90 b/flang/test/Semantics/separate-mp03.f90
index 33bf1cf8e414fd5..1bbeced44a4f7a2 100644
--- a/flang/test/Semantics/separate-mp03.f90
+++ b/flang/test/Semantics/separate-mp03.f90
@@ -74,7 +74,7 @@ pure module subroutine s2
end interface
contains
integer module function f1(x)
- !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has type REAL(4)
+ !ERROR: Dummy argument 'x' has type INTEGER(4); the corresponding argument in the interface body has distinct type REAL(4)
integer, intent(in) :: x
f1 = x
end function
diff --git a/flang/test/Semantics/separate-mp06.f90 b/flang/test/Semantics/separate-mp06.f90
new file mode 100644
index 000000000000000..9c76466d726dc63
--- /dev/null
+++ b/flang/test/Semantics/separate-mp06.f90
@@ -0,0 +1,98 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Structural equivalence of derived type definitions
+module m
+ interface
+ module subroutine s1(x)
+ type :: nonseq
+ integer :: n
+ end type
+ type(nonseq), intent(in) :: x
+ end subroutine
+ module subroutine s2(x)
+ type :: seq
+ sequence
+ integer :: n
+ end type
+ type(seq), intent(in) :: x
+ end subroutine
+ module subroutine s3(x)
+ type :: chlen
+ sequence
+ character(2) :: s
+ end type
+ type(chlen), intent(in) :: x
+ end subroutine
+ module subroutine s4(x)
+ !ERROR: A sequence type may not have type parameters
+ type :: pdt(k)
+ integer, kind :: k
+ sequence
+ real(k) :: a
+ end type
+ type(pdt(4)), intent(in) :: x
+ end subroutine
+ end interface
+end module
+
+submodule(m) sm
+ contains
+ module subroutine s1(x)
+ type :: nonseq
+ integer :: n
+ end type
+ !ERROR: Dummy argument 'x' has type nonseq; the corresponding argument in the interface body has distinct type nonseq
+ type(nonseq), intent(in) :: x
+ end subroutine
+ module subroutine s2(x) ! ok
+ type :: seq
+ sequence
+ integer :: n
+ end type
+ type(seq), intent(in) :: x
+ end subroutine
+ module subroutine s3(x)
+ type :: chlen
+ sequence
+ character(3) :: s ! note: length is 3, not 2
+ end type
+ !ERROR: Dummy argument 'x' has type chlen; the corresponding argument in the interface body has distinct type chlen
+ type(chlen), intent(in) :: x
+ end subroutine
+ module subroutine s4(x)
+ !ERROR: A sequence type may not have type parameters
+ type :: pdt(k)
+ integer, kind :: k
+ sequence
+ real(k) :: a
+ end type
+ !ERROR: Dummy argument 'x' has type pdt(k=4_4); the corresponding argument in the interface body has distinct type pdt(k=4_4)
+ type(pdt(4)), intent(in) :: x
+ end subroutine
+end submodule
+
+program main
+ use m
+ type :: nonseq
+ integer :: n
+ end type
+ type :: seq
+ sequence
+ integer :: n
+ end type
+ type :: chlen
+ sequence
+ character(2) :: s
+ end type
+ !ERROR: A sequence type may not have type parameters
+ type :: pdt(k)
+ integer, kind :: k
+ sequence
+ real(k) :: a
+ end type
+ !ERROR: Actual argument type 'nonseq' is not compatible with dummy argument type 'nonseq'
+ call s1(nonseq(1))
+ call s2(seq(1)) ! ok
+ call s3(chlen('ab')) ! ok, matches interface
+ !ERROR: Actual argument type 'pdt(k=4_4)' is not compatible with dummy argument type 'pdt(k=4_4)'
+ call s4(pdt(4)(3.14159))
+end program
More information about the flang-commits
mailing list