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