[flang-commits] [flang] 5eba975 - [flang][semantics] make sure dynamic type inquiry functions take extensible or unlimited polymorphic types (#162931)
via flang-commits
flang-commits at lists.llvm.org
Wed Oct 15 18:47:47 PDT 2025
Author: Andre Kuhlenschmidt
Date: 2025-10-15T18:47:43-07:00
New Revision: 5eba975f58d152454519bad387b2fb963659c03c
URL: https://github.com/llvm/llvm-project/commit/5eba975f58d152454519bad387b2fb963659c03c
DIFF: https://github.com/llvm/llvm-project/commit/5eba975f58d152454519bad387b2fb963659c03c.diff
LOG: [flang][semantics] make sure dynamic type inquiry functions take extensible or unlimited polymorphic types (#162931)
Adds error message when type is derived but not extensible and more
detailed error message when the type doesn't match.
fixes [#162712](https://github.com/llvm/llvm-project/issues/162712)
Added:
flang/test/Semantics/dynamic-type-intrinsics.f90
Modified:
flang/lib/Evaluate/intrinsics.cpp
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index f204eef54ef84..1de5e6b53ba71 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,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category())) {
+ 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'"_err_en_US, d.keyword,
- type->AsFortran());
+ "Actual argument for '%s=' has bad type '%s'%s"_err_en_US, d.keyword,
+ type->AsFortran(), expected);
return std::nullopt; // argument has invalid type category
}
bool argOk{false};
@@ -2244,6 +2250,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 type '%s', but was expected to be an extensible 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..a4ce3db2532c5
--- /dev/null
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -0,0 +1,73 @@
+! 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
+
+ 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
+ !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 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 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 or unlimited polymorphic type
+ logical :: t1_10 = same_type_as(x1, x5)
+ !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 or unlimited polymorphic type
+ logical :: t1_12 = same_type_as(r, r)
+ !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
+ 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
+ !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 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 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 or unlimited polymorphic type
+ logical :: t2_11 = extends_type_of(x1, x5)
+end module
More information about the flang-commits
mailing list