[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
Fri Oct 10 15:17:54 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/3] 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/3] 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/3] 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
More information about the flang-commits
mailing list