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
19 namespace Fortran::semantics {
20
21 class TypeCaseValues {
22 public:
TypeCaseValues(SemanticsContext & c,const evaluate::DynamicType & t)23 TypeCaseValues(SemanticsContext &c, const evaluate::DynamicType &t)
24 : context_{c}, selectorType_{t} {}
Check(const std::list<parser::SelectTypeConstruct::TypeCase> & cases)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
34 private:
AddTypeCase(const parser::SelectTypeConstruct::TypeCase & c)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
GetGuardType(const parser::TypeGuardStmt::Guard & guard)52 std::optional<evaluate::DynamicType> GetGuardType(
53 const parser::TypeGuardStmt::Guard &guard) {
54 return std::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
PassesChecksOnGuard(const parser::Statement<parser::TypeGuardStmt> & stmt,const evaluate::DynamicType & guardDynamicType)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 std::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 context_.Say(parser::FindSourceLocation(typeSpec),
98 "The type specification statement must have "
99 "LEN type parameter as assumed"_err_en_US);
100 typeSpecRetVal = false;
101 }
102 } else {
103 const DerivedTypeSpec *derived{spec->AsDerived()};
104 typeSpecRetVal = PassesDerivedTypeChecks(
105 *derived, parser::FindSourceLocation(typeSpec));
106 }
107 return typeSpecRetVal;
108 },
109 [&](const parser::DerivedTypeSpec &x) {
110 CHECK(x.derivedTypeSpec);
111 const semantics::DerivedTypeSpec *derived{x.derivedTypeSpec};
112 return PassesDerivedTypeChecks(
113 *derived, parser::FindSourceLocation(x));
114 },
115 },
116 guard.u);
117 }
118
PassesDerivedTypeChecks(const semantics::DerivedTypeSpec & derived,parser::CharBlock sourceLoc) const119 bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived,
120 parser::CharBlock sourceLoc) const {
121 for (const auto &pair : derived.parameters()) {
122 if (pair.second.isLen() && !pair.second.isAssumed()) { // C1160
123 context_.Say(sourceLoc,
124 "The type specification statement must have "
125 "LEN type parameter as assumed"_err_en_US);
126 return false;
127 }
128 }
129 if (!IsExtensibleType(&derived)) { // C1161
130 context_.Say(sourceLoc,
131 "The type specification statement must not specify "
132 "a type with a SEQUENCE attribute or a BIND attribute"_err_en_US);
133 return false;
134 }
135 if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
136 if (const semantics::Scope * guardScope{derived.typeSymbol().scope()}) {
137 if (const auto *selDerivedTypeSpec{
138 evaluate::GetDerivedTypeSpec(selectorType_)}) {
139 if (!(derived == *selDerivedTypeSpec) &&
140 !guardScope->FindComponent(selDerivedTypeSpec->name())) {
141 context_.Say(sourceLoc,
142 "Type specification '%s' must be an extension"
143 " of TYPE '%s'"_err_en_US,
144 derived.AsFortran(), selDerivedTypeSpec->AsFortran());
145 return false;
146 }
147 }
148 }
149 }
150 return true;
151 }
152
153 struct TypeCase {
TypeCaseFortran::semantics::TypeCaseValues::TypeCase154 explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s,
155 std::optional<evaluate::DynamicType> guardTypeDynamic)
156 : stmt{s} {
157 SetGuardType(guardTypeDynamic);
158 }
159
SetGuardTypeFortran::semantics::TypeCaseValues::TypeCase160 void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) {
161 const auto &guard{GetGuardFromStmt(stmt)};
162 std::visit(common::visitors{
163 [&](const parser::Default &) {},
164 [&](const auto &) { guardType_ = *guardTypeDynamic; },
165 },
166 guard.u);
167 }
168
IsDefaultFortran::semantics::TypeCaseValues::TypeCase169 bool IsDefault() const {
170 const auto &guard{GetGuardFromStmt(stmt)};
171 return std::holds_alternative<parser::Default>(guard.u);
172 }
173
IsTypeSpecFortran::semantics::TypeCaseValues::TypeCase174 bool IsTypeSpec() const {
175 const auto &guard{GetGuardFromStmt(stmt)};
176 return std::holds_alternative<parser::TypeSpec>(guard.u);
177 }
178
IsDerivedTypeSpecFortran::semantics::TypeCaseValues::TypeCase179 bool IsDerivedTypeSpec() const {
180 const auto &guard{GetGuardFromStmt(stmt)};
181 return std::holds_alternative<parser::DerivedTypeSpec>(guard.u);
182 }
183
GetGuardFromStmtFortran::semantics::TypeCaseValues::TypeCase184 const parser::TypeGuardStmt::Guard &GetGuardFromStmt(
185 const parser::Statement<parser::TypeGuardStmt> &stmt) const {
186 const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
187 return std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t);
188 }
189
guardTypeFortran::semantics::TypeCaseValues::TypeCase190 std::optional<evaluate::DynamicType> guardType() const {
191 return guardType_;
192 }
193
AsFortranFortran::semantics::TypeCaseValues::TypeCase194 std::string AsFortran() const {
195 std::string result;
196 if (this->guardType()) {
197 auto type{*this->guardType()};
198 result += type.AsFortran();
199 } else {
200 result += "DEFAULT";
201 }
202 return result;
203 }
204 const parser::Statement<parser::TypeGuardStmt> &stmt;
205 std::optional<evaluate::DynamicType> guardType_; // is this POD?
206 };
207
208 // Returns true if and only if the values are different
209 // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec
210 // checks for kinds as well.
TypesAreDifferent(const TypeCase & x,const TypeCase & y)211 static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) {
212 if (x.IsDefault()) { // C1164
213 return !y.IsDefault();
214 } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163
215 return !AreTypeKindCompatible(x, y);
216 } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163
217 return !AreTypeKindCompatible(x, y);
218 }
219 return true;
220 }
221
AreTypeKindCompatible(const TypeCase & x,const TypeCase & y)222 static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) {
223 return (*x.guardType()).IsTkCompatibleWith((*y.guardType()));
224 }
225
ReportConflictingTypeCases()226 void ReportConflictingTypeCases() {
227 for (auto iter{typeCases_.begin()}; iter != typeCases_.end(); ++iter) {
228 parser::Message *msg{nullptr};
229 for (auto p{typeCases_.begin()}; p != typeCases_.end(); ++p) {
230 if (p->stmt.source.begin() < iter->stmt.source.begin() &&
231 !TypesAreDifferent(*p, *iter)) {
232 if (!msg) {
233 msg = &context_.Say(iter->stmt.source,
234 "Type specification '%s' conflicts with "
235 "previous type specification"_err_en_US,
236 iter->AsFortran());
237 }
238 msg->Attach(p->stmt.source,
239 "Conflicting type specification '%s'"_en_US, p->AsFortran());
240 }
241 }
242 }
243 }
244
245 SemanticsContext &context_;
246 const evaluate::DynamicType &selectorType_;
247 std::list<TypeCase> typeCases_;
248 bool hasErrors_{false};
249 };
250
Enter(const parser::SelectTypeConstruct & construct)251 void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
252 const auto &selectTypeStmt{
253 std::get<parser::Statement<parser::SelectTypeStmt>>(construct.t)};
254 const auto &selectType{selectTypeStmt.statement};
255 const auto &unResolvedSel{std::get<parser::Selector>(selectType.t)};
256 const auto *selector{GetExprFromSelector(unResolvedSel)};
257
258 if (!selector) {
259 return; // expression semantics failed on Selector
260 }
261 if (auto exprType{selector->GetType()}) {
262 const auto &typeCaseList{
263 std::get<std::list<parser::SelectTypeConstruct::TypeCase>>(
264 construct.t)};
265 TypeCaseValues{context_, *exprType}.Check(typeCaseList);
266 }
267 }
268
GetExprFromSelector(const parser::Selector & selector)269 const SomeExpr *SelectTypeChecker::GetExprFromSelector(
270 const parser::Selector &selector) {
271 return std::visit([](const auto &x) { return GetExpr(x); }, selector.u);
272 }
273 } // namespace Fortran::semantics
274