1//===-- lib/Semantics/check-select-type.cpp -------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9#include "check-select-type.h"
10#include "flang/Common/idioms.h"
11#include "flang/Common/reference.h"
12#include "flang/Evaluate/fold.h"
13#include "flang/Evaluate/type.h"
14#include "flang/Parser/parse-tree.h"
15#include "flang/Semantics/semantics.h"
16#include "flang/Semantics/tools.h"
17#include <optional>
18
19namespace Fortran::semantics {
20
21class TypeCaseValues {
22public:
23 TypeCaseValues(SemanticsContext &c, const evaluate::DynamicType &t)
24 : context_{c}, selectorType_{t} {}
25 void Check(const std::list<parser::SelectTypeConstruct::TypeCase> &cases) {
26 for (const auto &c : cases) {
27 AddTypeCase(c);
28 }
29 if (!hasErrors_) {
30 ReportConflictingTypeCases();
31 }
32 }
33
34private:
35 void AddTypeCase(const parser::SelectTypeConstruct::TypeCase &c) {
36 const auto &stmt{std::get<parser::Statement<parser::TypeGuardStmt>>(c.t)};
37 const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
38 const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
39 if (std::holds_alternative<parser::Default>(guard.u)) {
40 typeCases_.emplace_back(stmt, std::nullopt);
41 } else if (std::optional<evaluate::DynamicType> type{GetGuardType(guard)}) {
42 if (PassesChecksOnGuard(stmt, *type)) {
43 typeCases_.emplace_back(stmt, *type);
44 } else {
45 hasErrors_ = true;
46 }
47 } else {
48 hasErrors_ = true;
49 }
50 }
51
52 std::optional<evaluate::DynamicType> GetGuardType(
53 const parser::TypeGuardStmt::Guard &guard) {
54 return common::visit(
55 common::visitors{
56 [](const parser::Default &)
57 -> std::optional<evaluate::DynamicType> {
58 return std::nullopt;
59 },
60 [](const parser::TypeSpec &typeSpec) {
61 return evaluate::DynamicType::From(typeSpec.declTypeSpec);
62 },
63 [](const parser::DerivedTypeSpec &spec)
64 -> std::optional<evaluate::DynamicType> {
65 if (const auto *derivedTypeSpec{spec.derivedTypeSpec}) {
66 return evaluate::DynamicType(*derivedTypeSpec);
67 }
68 return std::nullopt;
69 },
70 },
71 guard.u);
72 }
73
74 bool PassesChecksOnGuard(const parser::Statement<parser::TypeGuardStmt> &stmt,
75 const evaluate::DynamicType &guardDynamicType) {
76 const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
77 const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
78 return common::visit(
79 common::visitors{
80 [](const parser::Default &) { return true; },
81 [&](const parser::TypeSpec &typeSpec) {
82 const DeclTypeSpec *spec{typeSpec.declTypeSpec};
83 CHECK(spec);
84 CHECK(spec->AsIntrinsic() || spec->AsDerived());
85 bool typeSpecRetVal{false};
86 if (spec->AsIntrinsic()) {
87 typeSpecRetVal = true;
88 if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
89 context_.Say(stmt.source,
90 "If selector is not unlimited polymorphic, "
91 "an intrinsic type specification must not be specified "
92 "in the type guard statement"_err_en_US);
93 typeSpecRetVal = false;
94 }
95 if (spec->category() == DeclTypeSpec::Character &&
96 !guardDynamicType.IsAssumedLengthCharacter()) { // C1160
97 auto location{parser::FindSourceLocation(typeSpec)};
98 context_.Say(location.empty() ? stmt.source : location,
99 "The type specification statement must have "
100 "LEN type parameter as assumed"_err_en_US);
101 typeSpecRetVal = false;
102 }
103 } else {
104 const DerivedTypeSpec *derived{spec->AsDerived()};
105 typeSpecRetVal = PassesDerivedTypeChecks(
106 *derived, parser::FindSourceLocation(typeSpec));
107 }
108 return typeSpecRetVal;
109 },
110 [&](const parser::DerivedTypeSpec &x) {
111 CHECK(x.derivedTypeSpec);
112 const semantics::DerivedTypeSpec *derived{x.derivedTypeSpec};
113 return PassesDerivedTypeChecks(
114 *derived, parser::FindSourceLocation(x));
115 },
116 },
117 guard.u);
118 }
119
120 bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived,
121 parser::CharBlock sourceLoc) const {
122 for (const auto &pair : derived.parameters()) {
123 if (pair.second.isLen() && !pair.second.isAssumed()) { // F'2023 C1165
124 context_.Say(sourceLoc,
125 "The type specification statement must have LEN type parameter as assumed"_err_en_US);
126 return false;
127 }
128 }
129 if (!IsExtensibleType(&derived)) { // F'2023 C1166
130 context_.Say(sourceLoc,
131 "The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute"_err_en_US);
132 return false;
133 }
134 if (!selectorType_.IsUnlimitedPolymorphic()) { // F'2023 C1167
135 if (const auto *selDerivedTypeSpec{
136 evaluate::GetDerivedTypeSpec(selectorType_)}) {
137 if (!derived.MatchesOrExtends(*selDerivedTypeSpec)) {
138 context_.Say(sourceLoc,
139 "Type specification '%s' must be an extension of TYPE '%s'"_err_en_US,
140 derived.AsFortran(), selDerivedTypeSpec->AsFortran());
141 return false;
142 }
143 }
144 }
145 return true;
146 }
147
148 struct TypeCase {
149 explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s,
150 std::optional<evaluate::DynamicType> guardTypeDynamic)
151 : stmt{s} {
152 SetGuardType(guardTypeDynamic);
153 }
154
155 void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) {
156 const auto &guard{GetGuardFromStmt(stmt)};
157 common::visit(common::visitors{
158 [&](const parser::Default &) {},
159 [&](const auto &) { guardType_ = *guardTypeDynamic; },
160 },
161 guard.u);
162 }
163
164 bool IsDefault() const {
165 const auto &guard{GetGuardFromStmt(stmt)};
166 return std::holds_alternative<parser::Default>(guard.u);
167 }
168
169 bool IsTypeSpec() const {
170 const auto &guard{GetGuardFromStmt(stmt)};
171 return std::holds_alternative<parser::TypeSpec>(guard.u);
172 }
173
174 bool IsDerivedTypeSpec() const {
175 const auto &guard{GetGuardFromStmt(stmt)};
176 return std::holds_alternative<parser::DerivedTypeSpec>(guard.u);
177 }
178
179 const parser::TypeGuardStmt::Guard &GetGuardFromStmt(
180 const parser::Statement<parser::TypeGuardStmt> &stmt) const {
181 const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
182 return std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t);
183 }
184
185 std::optional<evaluate::DynamicType> guardType() const {
186 return guardType_;
187 }
188
189 std::string AsFortran() const {
190 std::string result;
191 if (this->guardType()) {
192 auto type{*this->guardType()};
193 result += type.AsFortran();
194 } else {
195 result += "DEFAULT";
196 }
197 return result;
198 }
199 const parser::Statement<parser::TypeGuardStmt> &stmt;
200 std::optional<evaluate::DynamicType> guardType_; // is this POD?
201 };
202
203 // Returns true if and only if the values are different
204 // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec
205 // checks for kinds as well.
206 static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) {
207 if (x.IsDefault()) { // C1164
208 return !y.IsDefault();
209 } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163
210 return !AreTypeKindCompatible(x, y);
211 } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163
212 return !AreTypeKindCompatible(x, y);
213 }
214 return true;
215 }
216
217 static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) {
218 return (*x.guardType()).IsTkCompatibleWith((*y.guardType()));
219 }
220
221 void ReportConflictingTypeCases() {
222 for (auto iter{typeCases_.begin()}; iter != typeCases_.end(); ++iter) {
223 parser::Message *msg{nullptr};
224 for (auto p{typeCases_.begin()}; p != typeCases_.end(); ++p) {
225 if (p->stmt.source.begin() < iter->stmt.source.begin() &&
226 !TypesAreDifferent(*p, *iter)) {
227 if (!msg) {
228 msg = &context_.Say(iter->stmt.source,
229 "Type specification '%s' conflicts with "
230 "previous type specification"_err_en_US,
231 iter->AsFortran());
232 }
233 msg->Attach(p->stmt.source,
234 "Conflicting type specification '%s'"_en_US, p->AsFortran());
235 }
236 }
237 }
238 }
239
240 SemanticsContext &context_;
241 const evaluate::DynamicType &selectorType_;
242 std::list<TypeCase> typeCases_;
243 bool hasErrors_{false};
244};
245
246void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
247 const auto &selectTypeStmt{
248 std::get<parser::Statement<parser::SelectTypeStmt>>(construct.t)};
249 const auto &selectType{selectTypeStmt.statement};
250 const auto &unResolvedSel{std::get<parser::Selector>(selectType.t)};
251 if (const auto *selector{GetExprFromSelector(unResolvedSel)}) {
252 if (IsProcedure(*selector)) {
253 context_.Say(
254 selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
255 } else if (evaluate::IsAssumedRank(*selector)) {
256 context_.Say(selectTypeStmt.source,
257 "Assumed-rank variable may only be used as actual argument"_err_en_US);
258 } else if (auto exprType{selector->GetType()}) {
259 const auto &typeCaseList{
260 std::get<std::list<parser::SelectTypeConstruct::TypeCase>>(
261 construct.t)};
262 TypeCaseValues{context_, *exprType}.Check(typeCaseList);
263 }
264 }
265}
266
267const SomeExpr *SelectTypeChecker::GetExprFromSelector(
268 const parser::Selector &selector) {
269 return common::visit([](const auto &x) { return GetExpr(x); }, selector.u);
270}
271} // namespace Fortran::semantics
272

source code of flang/lib/Semantics/check-select-type.cpp