Skip to content

Commit 5eba975

Browse files
akuhlensakuhlens
authored
[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](llvm/llvm-project#162712)
1 parent 754ebc6 commit 5eba975

File tree

2 files changed

+93
-3
lines changed

2 files changed

+93
-3
lines changed

‎flang/lib/Evaluate/intrinsics.cpp‎

Lines changed: 20 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
111111
atomicIntKind, // atomic_int_kind from iso_fortran_env
112112
atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
113113
sameAtom, // same type and kind as atom
114+
extensibleOrUnlimitedType, // extensible or unlimited polymorphic type
114115
)
115116

116117
struct TypePattern {
@@ -160,7 +161,8 @@ static constexpr TypePattern AnyChar{CharType, KindCode::any};
160161
static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
161162
static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
162163
static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
163-
static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};
164+
static constexpr TypePattern ExtensibleDerived{
165+
DerivedType, KindCode::extensibleOrUnlimitedType};
164166
static constexpr TypePattern AnyData{AnyType, KindCode::any};
165167

166168
// Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
@@ -2103,9 +2105,13 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
21032105
}
21042106
return std::nullopt;
21052107
} else if (!d.typePattern.categorySet.test(type->category())) {
2108+
const char *expected{
2109+
d.typePattern.kindCode == KindCode::extensibleOrUnlimitedType
2110+
? ", expected extensible or unlimited polymorphic type"
2111+
: ""};
21062112
messages.Say(arg->sourceLocation(),
2107-
"Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword,
2108-
type->AsFortran());
2113+
"Actual argument for '%s=' has bad type '%s'%s"_err_en_US, d.keyword,
2114+
type->AsFortran(), expected);
21092115
return std::nullopt; // argument has invalid type category
21102116
}
21112117
bool argOk{false};
@@ -2244,6 +2250,17 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
22442250
return std::nullopt;
22452251
}
22462252
break;
2253+
case KindCode::extensibleOrUnlimitedType:
2254+
argOk = type->IsUnlimitedPolymorphic() ||
2255+
(type->category() == TypeCategory::Derived &&
2256+
IsExtensibleType(GetDerivedTypeSpec(type)));
2257+
if (!argOk) {
2258+
messages.Say(arg->sourceLocation(),
2259+
"Actual argument for '%s=' has type '%s', but was expected to be an extensible or unlimited polymorphic type"_err_en_US,
2260+
d.keyword, type->AsFortran());
2261+
return std::nullopt;
2262+
}
2263+
break;
22472264
default:
22482265
CRASH_NO_CASE;
22492266
}

‎flang/test/Semantics/dynamic-type-intrinsics.f90‎

Lines changed: 73 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,73 @@
1+
! RUN: %python %S/test_errors.py %s %flang_fc1
2+
3+
module m
4+
type :: t1
5+
real :: x
6+
end type
7+
type :: t2(k)
8+
integer, kind :: k
9+
real(kind=k) :: x
10+
end type
11+
type :: t3
12+
real :: x
13+
end type
14+
type, extends(t1) :: t4
15+
integer :: y
16+
end type
17+
type :: t5
18+
sequence
19+
integer :: x
20+
integer :: y
21+
end type
22+
23+
integer :: i
24+
real :: r
25+
type(t1) :: x1, y1
26+
type(t2(4)) :: x24, y24
27+
type(t2(8)) :: x28
28+
type(t3) :: x3
29+
type(t4) :: x4
30+
type(t5) :: x5
31+
class(t1), allocatable :: a1
32+
class(t3), allocatable :: a3
33+
34+
integer(kind=merge(kind(1),-1,same_type_as(x1, x1))) same_type_as_x1_x1_true
35+
integer(kind=merge(kind(1),-1,same_type_as(x1, y1))) same_type_as_x1_y1_true
36+
integer(kind=merge(kind(1),-1,same_type_as(x24, x24))) same_type_as_x24_x24_true
37+
integer(kind=merge(kind(1),-1,same_type_as(x24, y24))) same_type_as_x24_y24_true
38+
integer(kind=merge(kind(1),-1,same_type_as(x24, x28))) same_type_as_x24_x28_true
39+
!ERROR: INTEGER(KIND=-1) is not a supported type
40+
integer(kind=merge(kind(1),-1,same_type_as(x1, x3))) same_type_as_x1_x3_false
41+
!ERROR: INTEGER(KIND=-1) is not a supported type
42+
integer(kind=merge(kind(1),-1,same_type_as(a1, a3))) same_type_as_a1_a3_false
43+
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
44+
logical :: t1_8 = same_type_as(x5, x5)
45+
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
46+
logical :: t1_9 = same_type_as(x5, x1)
47+
!ERROR: Actual argument for 'b=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
48+
logical :: t1_10 = same_type_as(x1, x5)
49+
!ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible or unlimited polymorphic type
50+
logical :: t1_11 = same_type_as(i, i)
51+
!ERROR: Actual argument for 'a=' has bad type 'REAL(4)', expected extensible or unlimited polymorphic type
52+
logical :: t1_12 = same_type_as(r, r)
53+
!ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible or unlimited polymorphic type
54+
logical :: t1_13 = same_type_as(i, t)
55+
56+
integer(kind=merge(kind(1),-1,extends_type_of(x1, y1))) extends_type_of_x1_y1_true
57+
integer(kind=merge(kind(1),-1,extends_type_of(x24, x24))) extends_type_of_x24_x24_true
58+
integer(kind=merge(kind(1),-1,extends_type_of(x24, y24))) extends_type_of_x24_y24_true
59+
integer(kind=merge(kind(1),-1,extends_type_of(x24, x28))) extends_type_of_x24_x28_true
60+
!ERROR: INTEGER(KIND=-1) is not a supported type
61+
integer(kind=merge(kind(1),-1,extends_type_of(x1, x3))) extends_type_of_x1_x3_false
62+
!ERROR: INTEGER(KIND=-1) is not a supported type
63+
integer(kind=merge(kind(1),-1,extends_type_of(a1, a3))) extends_type_of_a1_a3_false
64+
!ERROR: INTEGER(KIND=-1) is not a supported type
65+
integer(kind=merge(kind(1),-1,extends_type_of(x1, x4))) extends_type_of_x1_x4_false
66+
integer(kind=merge(kind(1),-1,extends_type_of(x4, x1))) extends_type_of_x4_x1_true
67+
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
68+
logical :: t2_9 = extends_type_of(x5, x5)
69+
!ERROR: Actual argument for 'a=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
70+
logical :: t2_10 = extends_type_of(x5, x1)
71+
!ERROR: Actual argument for 'mold=' has type 't5', but was expected to be an extensible or unlimited polymorphic type
72+
logical :: t2_11 = extends_type_of(x1, x5)
73+
end module

0 commit comments

Comments
 (0)