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:
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 
34 private:
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                   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 
119   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.Match(*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 {
154     explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s,
155         std::optional<evaluate::DynamicType> guardTypeDynamic)
156         : stmt{s} {
157       SetGuardType(guardTypeDynamic);
158     }
159 
160     void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) {
161       const auto &guard{GetGuardFromStmt(stmt)};
162       common::visit(common::visitors{
163                         [&](const parser::Default &) {},
164                         [&](const auto &) { guardType_ = *guardTypeDynamic; },
165                     },
166           guard.u);
167     }
168 
169     bool IsDefault() const {
170       const auto &guard{GetGuardFromStmt(stmt)};
171       return std::holds_alternative<parser::Default>(guard.u);
172     }
173 
174     bool IsTypeSpec() const {
175       const auto &guard{GetGuardFromStmt(stmt)};
176       return std::holds_alternative<parser::TypeSpec>(guard.u);
177     }
178 
179     bool IsDerivedTypeSpec() const {
180       const auto &guard{GetGuardFromStmt(stmt)};
181       return std::holds_alternative<parser::DerivedTypeSpec>(guard.u);
182     }
183 
184     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 
190     std::optional<evaluate::DynamicType> guardType() const {
191       return guardType_;
192     }
193 
194     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.
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 
222   static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) {
223     return (*x.guardType()).IsTkCompatibleWith((*y.guardType()));
224   }
225 
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 
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 
269 const SomeExpr *SelectTypeChecker::GetExprFromSelector(
270     const parser::Selector &selector) {
271   return common::visit([](const auto &x) { return GetExpr(x); }, selector.u);
272 }
273 } // namespace Fortran::semantics
274