272 lines · 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-exception6//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 19namespace Fortran::semantics {20 21class TypeCaseValues {22public: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 34private: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()) { // C116289 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()) { // C116097 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 C1165124 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 C1166130 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 C1167135 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 different204 // Does apple to apple comparision, in case of TypeSpec or DerivedTypeSpec205 // checks for kinds as well.206 static bool TypesAreDifferent(const TypeCase &x, const TypeCase &y) {207 if (x.IsDefault()) { // C1164208 return !y.IsDefault();209 } else if (x.IsTypeSpec() && y.IsTypeSpec()) { // C1163210 return !AreTypeKindCompatible(x, y);211 } else if (x.IsDerivedTypeSpec() && y.IsDerivedTypeSpec()) { // C1163212 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 246void 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 (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 267const SomeExpr *SelectTypeChecker::GetExprFromSelector(268 const parser::Selector &selector) {269 return common::visit([](const auto &x) { return GetExpr(x); }, selector.u);270}271} // namespace Fortran::semantics272