[flang-commits] [flang] [flang][semantics] make sure dynamic type inquiry functions take extensible or unlimited polymorphic types (PR #162931)
Andre Kuhlenschmidt via flang-commits
flang-commits at lists.llvm.org
Wed Oct 15 11:52:55 PDT 2025
https://github.com/akuhlens updated https://github.com/llvm/llvm-project/pull/162931
>From f9d0ef95e64ab749c5b4899f5784e750e381fcc4 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Thu, 9 Oct 2025 14:47:40 -0700
Subject: [PATCH 1/7] initial commit
---
flang/lib/Semantics/check-declarations.cpp | 2 ++
flang/test/Semantics/io11.f90 | 21 +++++++++++++++++++++
2 files changed, 23 insertions(+)
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index ea5e2c095d31a..31e246cf0ab03 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3622,6 +3622,7 @@ void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,
ioKind == common::DefinedIo::ReadUnformatted
? Attr::INTENT_INOUT
: Attr::INTENT_IN);
+ CheckDioDummyIsScalar(subp, *arg);
}
}
@@ -3687,6 +3688,7 @@ void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
"Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,
arg->name());
}
+ CheckDioDummyIsScalar(subp, *arg);
}
}
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index c00deede6b516..6bb7a71f0defc 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -809,3 +809,24 @@ subroutine wf(dtv, unit, iotype, v_list, iostat, iomsg)
end
end interface
end
+
+module m30
+ type base
+ character(5), allocatable :: data
+ end type
+ interface write(formatted)
+ subroutine formattedRead (dtv, unit, iotype, v_list, iostat, iomsg)
+ import base
+ !ERROR: Dummy argument 'dtv' of a defined input/output procedure must be a scalar
+ class (base), intent(in) :: dtv(10)
+ integer, intent(in) :: unit
+ !ERROR: Dummy argument 'iotype' of a defined input/output procedure must be a scalar
+ character(*), intent(in) :: iotype(2)
+ integer, intent(in) :: v_list(:)
+ !ERROR: Dummy argument 'iostat' of a defined input/output procedure must be a scalar
+ integer, intent(out) :: iostat(*)
+ !ERROR: Dummy argument 'iomsg' of a defined input/output procedure must be a scalar
+ character(*), intent(inout) :: iomsg(:)
+ end subroutine
+ end interface
+end module
>From 84851cda9a369784e0444ad538183e8d23b40c93 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Fri, 10 Oct 2025 15:02:42 -0700
Subject: [PATCH 2/7] initial commit
---
flang/lib/Evaluate/intrinsics.cpp | 28 +++++++-
.../Semantics/dynamic-type-intrinsics.f90 | 71 +++++++++++++++++++
2 files changed, 96 insertions(+), 3 deletions(-)
create mode 100644 flang/test/Semantics/dynamic-type-intrinsics.f90
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index f204eef54ef84..ec69197937a47 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -111,6 +111,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
atomicIntKind, // atomic_int_kind from iso_fortran_env
atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
sameAtom, // same type and kind as atom
+ ExtensibleOrUnlimitedType, // extensible or unlimited polymorphic type
)
struct TypePattern {
@@ -160,7 +161,8 @@ static constexpr TypePattern AnyChar{CharType, KindCode::any};
static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
-static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};
+static constexpr TypePattern ExtensibleDerived{
+ DerivedType, KindCode::ExtensibleOrUnlimitedType};
static constexpr TypePattern AnyData{AnyType, KindCode::any};
// Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
@@ -2103,9 +2105,18 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category())) {
+ std::string expectedText;
+ switch (d.typePattern.kindCode) {
+ case KindCode::ExtensibleOrUnlimitedType:
+ expectedText = "extensible derived or unlimited polymorphic type";
+ break;
+ default:
+ break;
+ }
messages.Say(arg->sourceLocation(),
- "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword,
- type->AsFortran());
+ "Actual argument for '%s=' has bad type '%s'%s"_err_en_US, d.keyword,
+ type->AsFortran(),
+ expectedText.empty() ? "" : ", expected " + expectedText);
return std::nullopt; // argument has invalid type category
}
bool argOk{false};
@@ -2244,6 +2255,17 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
return std::nullopt;
}
break;
+ case KindCode::ExtensibleOrUnlimitedType:
+ argOk = type->IsUnlimitedPolymorphic() ||
+ (type->category() == TypeCategory::Derived &&
+ IsExtensibleType(GetDerivedTypeSpec(type)));
+ if (!argOk) {
+ messages.Say(arg->sourceLocation(),
+ "Actual argument for '%s=' has bad type '%s', expected extensible derived or unlimited polymorphic type"_err_en_US,
+ d.keyword, type->AsFortran());
+ return std::nullopt;
+ }
+ break;
default:
CRASH_NO_CASE;
}
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
new file mode 100644
index 0000000000000..f63f1ee483637
--- /dev/null
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -0,0 +1,71 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module m
+ type :: t1
+ real :: x
+ end type
+ type :: t2(k)
+ integer, kind :: k
+ real(kind=k) :: x
+ end type
+ type :: t3
+ real :: x
+ end type
+ type, extends(t1) :: t4
+ integer :: y
+ end type
+ type :: t5
+ sequence
+ integer :: x
+ integer :: y
+ end type
+
+
+ integer :: i
+ real :: r
+ type(t1) :: x1, y1
+ type(t2(4)) :: x24, y24
+ type(t2(8)) :: x28
+ type(t3) :: x3
+ type(t4) :: x4
+ type(t5) :: x5
+ class(t1), allocatable :: a1
+ class(t3), allocatable :: a3
+
+
+ logical :: t1_1 = same_type_as(x1, x1)
+ logical :: t1_2 = same_type_as(x1, y1)
+ logical :: t1_3 = same_type_as(x24, x24)
+ logical :: t1_4 = same_type_as(x24, y24)
+ logical :: t1_5 = same_type_as(x24, x28) ! ignores parameter
+ logical :: t1_6 = .not. same_type_as(x1, x3)
+ logical :: t1_7 = .not. same_type_as(a1, a3)
+ !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t1_8 = same_type_as(x5, x5)
+ !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t1_9 = same_type_as(x5, x1)
+ !ERROR: Actual argument for 'b=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t1_10 = same_type_as(x1, x5)
+ !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+ logical :: t1_11 = same_type_as(i, i)
+ !ERROR: Actual argument for 'a=' has bad type 'REAL(4)', expected extensible derived or unlimited polymorphic type
+ logical :: t1_12 = same_type_as(r, r)
+ !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+ logical :: t1_13 = same_type_as(i, t)
+
+ logical :: t2_1 = extends_type_of(x1, y1)
+ logical :: t2_2 = extends_type_of(x24, x24)
+ logical :: t2_3 = extends_type_of(x24, y24)
+ logical :: t2_4 = extends_type_of(x24, x28) ! ignores parameter
+ logical :: t2_5 = .not. extends_type_of(x1, x3)
+ logical :: t2_6 = .not. extends_type_of(a1, a3)
+ logical :: t2_7 = .not. extends_type_of(x1, x4)
+ logical :: t2_8 = extends_type_of(x4, x1)
+ !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t2_9 = extends_type_of(x5, x5)
+ !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t2_10 = extends_type_of(x5, x1)
+ !ERROR: Actual argument for 'mold=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ logical :: t2_11 = extends_type_of(x1, x5)
+end module
+
\ No newline at end of file
>From 3044c06fc0db3ca99b3129b205d132db68083774 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Fri, 10 Oct 2025 15:17:41 -0700
Subject: [PATCH 3/7] remove mistakenly added files
---
flang/lib/Semantics/check-declarations.cpp | 2 --
flang/test/Semantics/io11.f90 | 21 ---------------------
2 files changed, 23 deletions(-)
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 31e246cf0ab03..ea5e2c095d31a 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3622,7 +3622,6 @@ void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,
ioKind == common::DefinedIo::ReadUnformatted
? Attr::INTENT_INOUT
: Attr::INTENT_IN);
- CheckDioDummyIsScalar(subp, *arg);
}
}
@@ -3688,7 +3687,6 @@ void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
"Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,
arg->name());
}
- CheckDioDummyIsScalar(subp, *arg);
}
}
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index 6bb7a71f0defc..c00deede6b516 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -809,24 +809,3 @@ subroutine wf(dtv, unit, iotype, v_list, iostat, iomsg)
end
end interface
end
-
-module m30
- type base
- character(5), allocatable :: data
- end type
- interface write(formatted)
- subroutine formattedRead (dtv, unit, iotype, v_list, iostat, iomsg)
- import base
- !ERROR: Dummy argument 'dtv' of a defined input/output procedure must be a scalar
- class (base), intent(in) :: dtv(10)
- integer, intent(in) :: unit
- !ERROR: Dummy argument 'iotype' of a defined input/output procedure must be a scalar
- character(*), intent(in) :: iotype(2)
- integer, intent(in) :: v_list(:)
- !ERROR: Dummy argument 'iostat' of a defined input/output procedure must be a scalar
- integer, intent(out) :: iostat(*)
- !ERROR: Dummy argument 'iomsg' of a defined input/output procedure must be a scalar
- character(*), intent(inout) :: iomsg(:)
- end subroutine
- end interface
-end module
>From 176c64c3ec43218d61bc27bedfee69aaf4a896a4 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Fri, 10 Oct 2025 15:19:55 -0700
Subject: [PATCH 4/7] fix whitespace in test
---
flang/test/Semantics/dynamic-type-intrinsics.f90 | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
index f63f1ee483637..12e87cc1b5793 100644
--- a/flang/test/Semantics/dynamic-type-intrinsics.f90
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -19,8 +19,7 @@ module m
integer :: x
integer :: y
end type
-
-
+
integer :: i
real :: r
type(t1) :: x1, y1
@@ -32,7 +31,6 @@ module m
class(t1), allocatable :: a1
class(t3), allocatable :: a3
-
logical :: t1_1 = same_type_as(x1, x1)
logical :: t1_2 = same_type_as(x1, y1)
logical :: t1_3 = same_type_as(x24, x24)
@@ -52,7 +50,7 @@ module m
logical :: t1_12 = same_type_as(r, r)
!ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
logical :: t1_13 = same_type_as(i, t)
-
+
logical :: t2_1 = extends_type_of(x1, y1)
logical :: t2_2 = extends_type_of(x24, x24)
logical :: t2_3 = extends_type_of(x24, y24)
@@ -68,4 +66,3 @@ module m
!ERROR: Actual argument for 'mold=' has bad type 't5', expected extensible derived or unlimited polymorphic type
logical :: t2_11 = extends_type_of(x1, x5)
end module
-
\ No newline at end of file
>From 0202c5e5890b422bf82eba60abaf465ba9c5cb7e Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Wed, 15 Oct 2025 10:31:45 -0700
Subject: [PATCH 5/7] address feedback
---
flang/lib/Evaluate/intrinsics.cpp | 10 ++---
.../Semantics/dynamic-type-intrinsics.f90 | 42 +++++++++----------
2 files changed, 26 insertions(+), 26 deletions(-)
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index ec69197937a47..ff71b119c48e7 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -111,7 +111,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
atomicIntKind, // atomic_int_kind from iso_fortran_env
atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
sameAtom, // same type and kind as atom
- ExtensibleOrUnlimitedType, // extensible or unlimited polymorphic type
+ extensibleOrUnlimitedType, // extensible or unlimited polymorphic type
)
struct TypePattern {
@@ -162,7 +162,7 @@ static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
static constexpr TypePattern ExtensibleDerived{
- DerivedType, KindCode::ExtensibleOrUnlimitedType};
+ DerivedType, KindCode::extensibleOrUnlimitedType};
static constexpr TypePattern AnyData{AnyType, KindCode::any};
// Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
@@ -2107,7 +2107,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
} else if (!d.typePattern.categorySet.test(type->category())) {
std::string expectedText;
switch (d.typePattern.kindCode) {
- case KindCode::ExtensibleOrUnlimitedType:
+ case KindCode::extensibleOrUnlimitedType:
expectedText = "extensible derived or unlimited polymorphic type";
break;
default:
@@ -2255,13 +2255,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
return std::nullopt;
}
break;
- case KindCode::ExtensibleOrUnlimitedType:
+ case KindCode::extensibleOrUnlimitedType:
argOk = type->IsUnlimitedPolymorphic() ||
(type->category() == TypeCategory::Derived &&
IsExtensibleType(GetDerivedTypeSpec(type)));
if (!argOk) {
messages.Say(arg->sourceLocation(),
- "Actual argument for '%s=' has bad type '%s', expected extensible derived or unlimited polymorphic type"_err_en_US,
+ "Actual argument for '%s=' has type '%s', but was expected to be an extensible derived or unlimited polymorphic type"_err_en_US,
d.keyword, type->AsFortran());
return std::nullopt;
}
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
index 12e87cc1b5793..2a0b316f33c99 100644
--- a/flang/test/Semantics/dynamic-type-intrinsics.f90
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -31,18 +31,18 @@ module m
class(t1), allocatable :: a1
class(t3), allocatable :: a3
- logical :: t1_1 = same_type_as(x1, x1)
- logical :: t1_2 = same_type_as(x1, y1)
- logical :: t1_3 = same_type_as(x24, x24)
- logical :: t1_4 = same_type_as(x24, y24)
- logical :: t1_5 = same_type_as(x24, x28) ! ignores parameter
- logical :: t1_6 = .not. same_type_as(x1, x3)
- logical :: t1_7 = .not. same_type_as(a1, a3)
- !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ integer(kind=merge(kind(1),-1,same_type_as(x1, x1))) same_type_as_x1_x1_true
+ integer(kind=merge(kind(1),-1,same_type_as(x1, y1))) same_type_as_x1_y1_true
+ integer(kind=merge(kind(1),-1,same_type_as(x24, x24))) same_type_as_x24_x24_true
+ integer(kind=merge(kind(1),-1,same_type_as(x24, y24))) same_type_as_x24_y24_true
+ integer(kind=merge(kind(1),-1,same_type_as(x24, x28))) same_type_as_x24_x28_true
+ integer(kind=merge(-1,kind(1),same_type_as(x1, x3))) same_type_as_x1_x3_false
+ integer(kind=merge(-1,kind(1),same_type_as(a1, a3))) same_type_as_a1_a3_false
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t1_8 = same_type_as(x5, x5)
- !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t1_9 = same_type_as(x5, x1)
- !ERROR: Actual argument for 'b=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'b=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t1_10 = same_type_as(x1, x5)
!ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
logical :: t1_11 = same_type_as(i, i)
@@ -51,18 +51,18 @@ module m
!ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
logical :: t1_13 = same_type_as(i, t)
- logical :: t2_1 = extends_type_of(x1, y1)
- logical :: t2_2 = extends_type_of(x24, x24)
- logical :: t2_3 = extends_type_of(x24, y24)
- logical :: t2_4 = extends_type_of(x24, x28) ! ignores parameter
- logical :: t2_5 = .not. extends_type_of(x1, x3)
- logical :: t2_6 = .not. extends_type_of(a1, a3)
- logical :: t2_7 = .not. extends_type_of(x1, x4)
- logical :: t2_8 = extends_type_of(x4, x1)
- !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ integer(kind=merge(kind(1),-1,extends_type_of(x1, y1))) extends_type_of_x1_y1_true
+ integer(kind=merge(kind(1),-1,extends_type_of(x24, x24))) extends_type_of_x24_x24_true
+ integer(kind=merge(kind(1),-1,extends_type_of(x24, y24))) extends_type_of_x24_y24_true
+ integer(kind=merge(kind(1),-1,extends_type_of(x24, x28))) extends_type_of_x24_x28_true
+ integer(kind=merge(-1,kind(1),extends_type_of(x1, x3))) extends_type_of_x1_x3_false
+ integer(kind=merge(-1,kind(1),extends_type_of(a1, a3))) extends_type_of_a1_a3_false
+ integer(kind=merge(-1,kind(1),extends_type_of(x1, x4))) extends_type_of_x1_x4_false
+ integer(kind=merge(kind(1),-1,extends_type_of(x4, x1))) extends_type_of_x4_x1_true
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t2_9 = extends_type_of(x5, x5)
- !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t2_10 = extends_type_of(x5, x1)
- !ERROR: Actual argument for 'mold=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'mold=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t2_11 = extends_type_of(x1, x5)
end module
>From cf1d47f968ff202032f6f0a9fa3e651f3b7c2847 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Wed, 15 Oct 2025 10:38:05 -0700
Subject: [PATCH 6/7] simplify checks of logical value
---
flang/test/Semantics/dynamic-type-intrinsics.f90 | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
index 2a0b316f33c99..c867a04726fc7 100644
--- a/flang/test/Semantics/dynamic-type-intrinsics.f90
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -36,8 +36,10 @@ module m
integer(kind=merge(kind(1),-1,same_type_as(x24, x24))) same_type_as_x24_x24_true
integer(kind=merge(kind(1),-1,same_type_as(x24, y24))) same_type_as_x24_y24_true
integer(kind=merge(kind(1),-1,same_type_as(x24, x28))) same_type_as_x24_x28_true
- integer(kind=merge(-1,kind(1),same_type_as(x1, x3))) same_type_as_x1_x3_false
- integer(kind=merge(-1,kind(1),same_type_as(a1, a3))) same_type_as_a1_a3_false
+ !ERROR: INTEGER(KIND=-1) is not a supported type
+ integer(kind=merge(kind(1),-1,same_type_as(x1, x3))) same_type_as_x1_x3_false
+ !ERROR: INTEGER(KIND=-1) is not a supported type
+ integer(kind=merge(kind(1),-1,same_type_as(a1, a3))) same_type_as_a1_a3_false
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t1_8 = same_type_as(x5, x5)
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
@@ -55,9 +57,12 @@ module m
integer(kind=merge(kind(1),-1,extends_type_of(x24, x24))) extends_type_of_x24_x24_true
integer(kind=merge(kind(1),-1,extends_type_of(x24, y24))) extends_type_of_x24_y24_true
integer(kind=merge(kind(1),-1,extends_type_of(x24, x28))) extends_type_of_x24_x28_true
- integer(kind=merge(-1,kind(1),extends_type_of(x1, x3))) extends_type_of_x1_x3_false
- integer(kind=merge(-1,kind(1),extends_type_of(a1, a3))) extends_type_of_a1_a3_false
- integer(kind=merge(-1,kind(1),extends_type_of(x1, x4))) extends_type_of_x1_x4_false
+ !ERROR: INTEGER(KIND=-1) is not a supported type
+ integer(kind=merge(kind(1),-1,extends_type_of(x1, x3))) extends_type_of_x1_x3_false
+ !ERROR: INTEGER(KIND=-1) is not a supported type
+ integer(kind=merge(kind(1),-1,extends_type_of(a1, a3))) extends_type_of_a1_a3_false
+ !ERROR: INTEGER(KIND=-1) is not a supported type
+ integer(kind=merge(kind(1),-1,extends_type_of(x1, x4))) extends_type_of_x1_x4_false
integer(kind=merge(kind(1),-1,extends_type_of(x4, x1))) extends_type_of_x4_x1_true
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
logical :: t2_9 = extends_type_of(x5, x5)
>From e6feea51508e389793d8939fbc6665d43c245c3d Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Wed, 15 Oct 2025 11:33:43 -0700
Subject: [PATCH 7/7] simplify error string creation
---
flang/lib/Evaluate/intrinsics.cpp | 17 ++++++-----------
.../test/Semantics/dynamic-type-intrinsics.f90 | 18 +++++++++---------
2 files changed, 15 insertions(+), 20 deletions(-)
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index ff71b119c48e7..1de5e6b53ba71 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2105,18 +2105,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category())) {
- std::string expectedText;
- switch (d.typePattern.kindCode) {
- case KindCode::extensibleOrUnlimitedType:
- expectedText = "extensible derived or unlimited polymorphic type";
- break;
- default:
- break;
- }
+ const char *expected{
+ d.typePattern.kindCode == KindCode::extensibleOrUnlimitedType
+ ? ", expected extensible or unlimited polymorphic type"
+ : ""};
messages.Say(arg->sourceLocation(),
"Actual argument for '%s=' has bad type '%s'%s"_err_en_US, d.keyword,
- type->AsFortran(),
- expectedText.empty() ? "" : ", expected " + expectedText);
+ type->AsFortran(), expected);
return std::nullopt; // argument has invalid type category
}
bool argOk{false};
@@ -2261,7 +2256,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
IsExtensibleType(GetDerivedTypeSpec(type)));
if (!argOk) {
messages.Say(arg->sourceLocation(),
- "Actual argument for '%s=' has type '%s', but was expected to be an extensible derived or unlimited polymorphic type"_err_en_US,
+ "Actual argument for '%s=' has type '%s', but was expected to be an extensible or unlimited polymorphic type"_err_en_US,
d.keyword, type->AsFortran());
return std::nullopt;
}
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
index c867a04726fc7..a4ce3db2532c5 100644
--- a/flang/test/Semantics/dynamic-type-intrinsics.f90
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -40,17 +40,17 @@ module m
integer(kind=merge(kind(1),-1,same_type_as(x1, x3))) same_type_as_x1_x3_false
!ERROR: INTEGER(KIND=-1) is not a supported type
integer(kind=merge(kind(1),-1,same_type_as(a1, a3))) same_type_as_a1_a3_false
- !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t1_8 = same_type_as(x5, x5)
- !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t1_9 = same_type_as(x5, x1)
- !ERROR: Actual argument for 'b=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'b=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t1_10 = same_type_as(x1, x5)
- !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible or unlimited polymorphic type
logical :: t1_11 = same_type_as(i, i)
- !ERROR: Actual argument for 'a=' has bad type 'REAL(4)', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has bad type 'REAL(4)', expected extensible or unlimited polymorphic type
logical :: t1_12 = same_type_as(r, r)
- !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible or unlimited polymorphic type
logical :: t1_13 = same_type_as(i, t)
integer(kind=merge(kind(1),-1,extends_type_of(x1, y1))) extends_type_of_x1_y1_true
@@ -64,10 +64,10 @@ module m
!ERROR: INTEGER(KIND=-1) is not a supported type
integer(kind=merge(kind(1),-1,extends_type_of(x1, x4))) extends_type_of_x1_x4_false
integer(kind=merge(kind(1),-1,extends_type_of(x4, x1))) extends_type_of_x4_x1_true
- !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t2_9 = extends_type_of(x5, x5)
- !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t2_10 = extends_type_of(x5, x1)
- !ERROR: Actual argument for 'mold=' has type 't5', but was expected to be an extensible derived or unlimited polymorphic type
+ !ERROR: Actual argument for 'mold=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
logical :: t2_11 = extends_type_of(x1, x5)
end module
More information about the flang-commits
mailing list