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()) { // 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
 246 void 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
 267 const 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