//===-- 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 common::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 common::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
auto location{parser::FindSourceLocation(typeSpec)};
context_.Say(location.empty() ? stmt.source : location,
"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()) { // F'2023 C1165
context_.Say(sourceLoc,
"The type specification statement must have LEN type parameter as assumed"_err_en_US);
return false;
}
}
if (!IsExtensibleType(&derived)) { // F'2023 C1166
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()) { // F'2023 C1167
if (const auto *selDerivedTypeSpec{
evaluate::GetDerivedTypeSpec(selectorType_)}) {
if (!derived.MatchesOrExtends(*selDerivedTypeSpec)) {
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)};
common::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)};
if (const auto *selector{GetExprFromSelector(unResolvedSel)}) {
if (IsProcedure(*selector)) {
context_.Say(
selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
} else if (evaluate::IsAssumedRank(*selector)) {
context_.Say(selectTypeStmt.source,
"Assumed-rank variable may only be used as actual argument"_err_en_US);
} else 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 common::visit([](const auto &x) { return GetExpr(x); }, selector.u);
}
} // namespace Fortran::semantics
Codebase Browser
llvm