flang/lib/Semantics/check-select-type.cpp

   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                   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()) { // C1160
 124         context_.Say(sourceLoc,
 125             "The type specification statement must have "
 126             "LEN type parameter as assumed"_err_en_US);
 127         return false;
 128       }
 129     }
 130     if (!IsExtensibleType(&derived)) { // C1161
 131       context_.Say(sourceLoc,
 132           "The type specification statement must not specify "
 133           "a type with a SEQUENCE attribute or a BIND attribute"_err_en_US);
 134       return false;
 135     }
 136     if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
 137       if (const semantics::Scope * guardScope{derived.typeSymbol().scope()}) {
 138         if (const auto *selDerivedTypeSpec{
 139                 evaluate::GetDerivedTypeSpec(selectorType_)}) {
 140           if (!derived.Match(*selDerivedTypeSpec) &&
 141               !guardScope->FindComponent(selDerivedTypeSpec->name())) {
 142             context_.Say(sourceLoc,
 143                 "Type specification '%s' must be an extension"
 144                 " of TYPE '%s'"_err_en_US,
 145                 derived.AsFortran(), selDerivedTypeSpec->AsFortran());
 146             return false;
 147           }
 148         }
 149       }
 150     }
 151     return true;
 152   }
 153
 154   struct TypeCase {
 155     explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s,
 156         std::optional<evaluate::DynamicType> guardTypeDynamic)
 157         : stmt{s} {
 158       SetGuardType(guardTypeDynamic);
 159     }
 160
 161     void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) {
 162       const auto &guard{GetGuardFromStmt(stmt)};
 163       common::visit(common::visitors{
 164                         [&](const parser::Default &) {},
 165                         [&](const auto &) { guardType_ = *guardTypeDynamic; },
 166                     },
 167           guard.u);
 168     }
 169
 170     bool IsDefault() const {
 171       const auto &guard{GetGuardFromStmt(stmt)};
 172       return std::holds_alternative<parser::Default>(guard.u);
 173     }
 174
 175     bool IsTypeSpec() const {
 176       const auto &guard{GetGuardFromStmt(stmt)};
 177       return std::holds_alternative<parser::TypeSpec>(guard.u);
 178     }
 179
 180     bool IsDerivedTypeSpec() const {
 181       const auto &guard{GetGuardFromStmt(stmt)};
 182       return std::holds_alternative<parser::DerivedTypeSpec>(guard.u);
 183     }
 184
 185     const parser::TypeGuardStmt::Guard &GetGuardFromStmt(
 186         const parser::Statement<parser::TypeGuardStmt> &stmt) const {
 187       const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
 188       return std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t);
 189     }
 190
 191     std::optional<evaluate::DynamicType> guardType() const {
 192       return guardType_;
 193     }
 194
 195     std::string AsFortran() const {
 196       std::string result;
 197       if (this->guardType()) {
 198         auto type{*this->guardType()};
 199         result += type.AsFortran();
 200       } else {
 201         result += "DEFAULT";
 202       }
 203       return result;
 204     }
 205     const parser::Statement<parser::TypeGuardStmt> &stmt;
 206     std::optional<evaluate::DynamicType> guardType_; // is this POD?
 207   };
 208
 209   // Returns true if and only if the values are different
 210   // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec
 211   // checks for kinds as well.
 212   static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) {
 213     if (x.IsDefault()) { // C1164
 214       return !y.IsDefault();
 215     } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163
 216       return !AreTypeKindCompatible(x, y);
 217     } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163
 218       return !AreTypeKindCompatible(x, y);
 219     }
 220     return true;
 221   }
 222
 223   static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) {
 224     return (*x.guardType()).IsTkCompatibleWith((*y.guardType()));
 225   }
 226
 227   void ReportConflictingTypeCases() {
 228     for (auto iter{typeCases_.begin()}; iter != typeCases_.end(); ++iter) {
 229       parser::Message *msg{nullptr};
 230       for (auto p{typeCases_.begin()}; p != typeCases_.end(); ++p) {
 231         if (p->stmt.source.begin() < iter->stmt.source.begin() &&
 232             !TypesAreDifferent(*p, *iter)) {
 233           if (!msg) {
 234             msg = &context_.Say(iter->stmt.source,
 235                 "Type specification '%s' conflicts with "
 236                 "previous type specification"_err_en_US,
 237                 iter->AsFortran());
 238           }
 239           msg->Attach(p->stmt.source,
 240               "Conflicting type specification '%s'"_en_US, p->AsFortran());
 241         }
 242       }
 243     }
 244   }
 245
 246   SemanticsContext &context_;
 247   const evaluate::DynamicType &selectorType_;
 248   std::list<TypeCase> typeCases_;
 249   bool hasErrors_{false};
 250 };
 251
 252 void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
 253   const auto &selectTypeStmt{
 254       std::get<parser::Statement<parser::SelectTypeStmt>>(construct.t)};
 255   const auto &selectType{selectTypeStmt.statement};
 256   const auto &unResolvedSel{std::get<parser::Selector>(selectType.t)};
 257   if (const auto *selector{GetExprFromSelector(unResolvedSel)}) {
 258     if (IsProcedure(*selector)) {
 259       context_.Say(
 260           selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
 261     } else 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
 270 const SomeExpr *SelectTypeChecker::GetExprFromSelector(
 271     const parser::Selector &selector) {
 272   return common::visit([](const auto &x) { return GetExpr(x); }, selector.u);
 273 }
 274 } // namespace Fortran::semantics