| //===-- lib/Semantics/check-select-type.cpp -------------------------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "check-select-type.h" |
| #include "flang/Common/idioms.h" |
| #include "flang/Common/reference.h" |
| #include "flang/Evaluate/fold.h" |
| #include "flang/Evaluate/type.h" |
| #include "flang/Parser/parse-tree.h" |
| #include "flang/Semantics/semantics.h" |
| #include "flang/Semantics/tools.h" |
| #include <optional> |
| |
| namespace Fortran::semantics { |
| |
| class TypeCaseValues { |
| public: |
| TypeCaseValues(SemanticsContext &c, const evaluate::DynamicType &t) |
| : context_{c}, selectorType_{t} {} |
| void Check(const std::list<parser::SelectTypeConstruct::TypeCase> &cases) { |
| for (const auto &c : cases) { |
| AddTypeCase(c); |
| } |
| if (!hasErrors_) { |
| ReportConflictingTypeCases(); |
| } |
| } |
| |
| private: |
| void AddTypeCase(const parser::SelectTypeConstruct::TypeCase &c) { |
| const auto &stmt{std::get<parser::Statement<parser::TypeGuardStmt>>(c.t)}; |
| const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; |
| const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)}; |
| if (std::holds_alternative<parser::Default>(guard.u)) { |
| typeCases_.emplace_back(stmt, std::nullopt); |
| } else if (std::optional<evaluate::DynamicType> type{GetGuardType(guard)}) { |
| if (PassesChecksOnGuard(stmt, *type)) { |
| typeCases_.emplace_back(stmt, *type); |
| } else { |
| hasErrors_ = true; |
| } |
| } else { |
| hasErrors_ = true; |
| } |
| } |
| |
| std::optional<evaluate::DynamicType> GetGuardType( |
| const parser::TypeGuardStmt::Guard &guard) { |
| return std::visit( |
| common::visitors{ |
| [](const parser::Default &) |
| -> std::optional<evaluate::DynamicType> { |
| return std::nullopt; |
| }, |
| [](const parser::TypeSpec &typeSpec) { |
| return evaluate::DynamicType::From(typeSpec.declTypeSpec); |
| }, |
| [](const parser::DerivedTypeSpec &spec) |
| -> std::optional<evaluate::DynamicType> { |
| if (const auto *derivedTypeSpec{spec.derivedTypeSpec}) { |
| return evaluate::DynamicType(*derivedTypeSpec); |
| } |
| return std::nullopt; |
| }, |
| }, |
| guard.u); |
| } |
| |
| bool PassesChecksOnGuard(const parser::Statement<parser::TypeGuardStmt> &stmt, |
| const evaluate::DynamicType &guardDynamicType) { |
| const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; |
| const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)}; |
| return std::visit( |
| common::visitors{ |
| [](const parser::Default &) { return true; }, |
| [&](const parser::TypeSpec &typeSpec) { |
| const DeclTypeSpec *spec{typeSpec.declTypeSpec}; |
| CHECK(spec); |
| CHECK(spec->AsIntrinsic() || spec->AsDerived()); |
| bool typeSpecRetVal{false}; |
| if (spec->AsIntrinsic()) { |
| typeSpecRetVal = true; |
| if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162 |
| context_.Say(stmt.source, |
| "If selector is not unlimited polymorphic, " |
| "an intrinsic type specification must not be specified " |
| "in the type guard statement"_err_en_US); |
| typeSpecRetVal = false; |
| } |
| if (spec->category() == DeclTypeSpec::Character && |
| !guardDynamicType.IsAssumedLengthCharacter()) { // C1160 |
| context_.Say(parser::FindSourceLocation(typeSpec), |
| "The type specification statement must have " |
| "LEN type parameter as assumed"_err_en_US); |
| typeSpecRetVal = false; |
| } |
| } else { |
| const DerivedTypeSpec *derived{spec->AsDerived()}; |
| typeSpecRetVal = PassesDerivedTypeChecks( |
| *derived, parser::FindSourceLocation(typeSpec)); |
| } |
| return typeSpecRetVal; |
| }, |
| [&](const parser::DerivedTypeSpec &x) { |
| CHECK(x.derivedTypeSpec); |
| const semantics::DerivedTypeSpec *derived{x.derivedTypeSpec}; |
| return PassesDerivedTypeChecks( |
| *derived, parser::FindSourceLocation(x)); |
| }, |
| }, |
| guard.u); |
| } |
| |
| bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived, |
| parser::CharBlock sourceLoc) const { |
| for (const auto &pair : derived.parameters()) { |
| if (pair.second.isLen() && !pair.second.isAssumed()) { // C1160 |
| context_.Say(sourceLoc, |
| "The type specification statement must have " |
| "LEN type parameter as assumed"_err_en_US); |
| return false; |
| } |
| } |
| if (!IsExtensibleType(&derived)) { // C1161 |
| context_.Say(sourceLoc, |
| "The type specification statement must not specify " |
| "a type with a SEQUENCE attribute or a BIND attribute"_err_en_US); |
| return false; |
| } |
| if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162 |
| if (const semantics::Scope * guardScope{derived.typeSymbol().scope()}) { |
| if (const auto *selDerivedTypeSpec{ |
| evaluate::GetDerivedTypeSpec(selectorType_)}) { |
| if (!(derived == *selDerivedTypeSpec) && |
| !guardScope->FindComponent(selDerivedTypeSpec->name())) { |
| context_.Say(sourceLoc, |
| "Type specification '%s' must be an extension" |
| " of TYPE '%s'"_err_en_US, |
| derived.AsFortran(), selDerivedTypeSpec->AsFortran()); |
| return false; |
| } |
| } |
| } |
| } |
| return true; |
| } |
| |
| struct TypeCase { |
| explicit TypeCase(const parser::Statement<parser::TypeGuardStmt> &s, |
| std::optional<evaluate::DynamicType> guardTypeDynamic) |
| : stmt{s} { |
| SetGuardType(guardTypeDynamic); |
| } |
| |
| void SetGuardType(std::optional<evaluate::DynamicType> guardTypeDynamic) { |
| const auto &guard{GetGuardFromStmt(stmt)}; |
| std::visit(common::visitors{ |
| [&](const parser::Default &) {}, |
| [&](const auto &) { guardType_ = *guardTypeDynamic; }, |
| }, |
| guard.u); |
| } |
| |
| bool IsDefault() const { |
| const auto &guard{GetGuardFromStmt(stmt)}; |
| return std::holds_alternative<parser::Default>(guard.u); |
| } |
| |
| bool IsTypeSpec() const { |
| const auto &guard{GetGuardFromStmt(stmt)}; |
| return std::holds_alternative<parser::TypeSpec>(guard.u); |
| } |
| |
| bool IsDerivedTypeSpec() const { |
| const auto &guard{GetGuardFromStmt(stmt)}; |
| return std::holds_alternative<parser::DerivedTypeSpec>(guard.u); |
| } |
| |
| const parser::TypeGuardStmt::Guard &GetGuardFromStmt( |
| const parser::Statement<parser::TypeGuardStmt> &stmt) const { |
| const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; |
| return std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t); |
| } |
| |
| std::optional<evaluate::DynamicType> guardType() const { |
| return guardType_; |
| } |
| |
| std::string AsFortran() const { |
| std::string result; |
| if (this->guardType()) { |
| auto type{*this->guardType()}; |
| result += type.AsFortran(); |
| } else { |
| result += "DEFAULT"; |
| } |
| return result; |
| } |
| const parser::Statement<parser::TypeGuardStmt> &stmt; |
| std::optional<evaluate::DynamicType> guardType_; // is this POD? |
| }; |
| |
| // Returns true if and only if the values are different |
| // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec |
| // checks for kinds as well. |
| static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) { |
| if (x.IsDefault()) { // C1164 |
| return !y.IsDefault(); |
| } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163 |
| return !AreTypeKindCompatible(x, y); |
| } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163 |
| return !AreTypeKindCompatible(x, y); |
| } |
| return true; |
| } |
| |
| static bool AreTypeKindCompatible(const TypeCase &x, const TypeCase &y) { |
| return (*x.guardType()).IsTkCompatibleWith((*y.guardType())); |
| } |
| |
| void ReportConflictingTypeCases() { |
| for (auto iter{typeCases_.begin()}; iter != typeCases_.end(); ++iter) { |
| parser::Message *msg{nullptr}; |
| for (auto p{typeCases_.begin()}; p != typeCases_.end(); ++p) { |
| if (p->stmt.source.begin() < iter->stmt.source.begin() && |
| !TypesAreDifferent(*p, *iter)) { |
| if (!msg) { |
| msg = &context_.Say(iter->stmt.source, |
| "Type specification '%s' conflicts with " |
| "previous type specification"_err_en_US, |
| iter->AsFortran()); |
| } |
| msg->Attach(p->stmt.source, |
| "Conflicting type specification '%s'"_en_US, p->AsFortran()); |
| } |
| } |
| } |
| } |
| |
| SemanticsContext &context_; |
| const evaluate::DynamicType &selectorType_; |
| std::list<TypeCase> typeCases_; |
| bool hasErrors_{false}; |
| }; |
| |
| void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) { |
| const auto &selectTypeStmt{ |
| std::get<parser::Statement<parser::SelectTypeStmt>>(construct.t)}; |
| const auto &selectType{selectTypeStmt.statement}; |
| const auto &unResolvedSel{std::get<parser::Selector>(selectType.t)}; |
| const auto *selector{GetExprFromSelector(unResolvedSel)}; |
| |
| if (!selector) { |
| return; // expression semantics failed on Selector |
| } |
| if (auto exprType{selector->GetType()}) { |
| const auto &typeCaseList{ |
| std::get<std::list<parser::SelectTypeConstruct::TypeCase>>( |
| construct.t)}; |
| TypeCaseValues{context_, *exprType}.Check(typeCaseList); |
| } |
| } |
| |
| const SomeExpr *SelectTypeChecker::GetExprFromSelector( |
| const parser::Selector &selector) { |
| return std::visit([](const auto &x) { return GetExpr(x); }, selector.u); |
| } |
| } // namespace Fortran::semantics |