From 7a77c20dbd613935d5817bda465f544ec98acc8a Mon Sep 17 00:00:00 2001 From: peter klausler Date: Thu, 26 Mar 2020 12:25:29 -0700 Subject: [PATCH] [flang] Semantics for SELECT CASE Prep for review Respond to review comments Fix first line in new test Original-commit: flang-compiler/f18@12f6f30600db4cb3902677cd42764450ddeda5e0 Reviewed-on: https://github.com/flang-compiler/f18/pull/1089 --- flang/include/flang/Evaluate/integer.h | 42 ++++-- flang/include/flang/Evaluate/logical.h | 38 ++++- flang/lib/Semantics/CMakeLists.txt | 1 + flang/lib/Semantics/check-case.cpp | 253 +++++++++++++++++++++++++++++++++ flang/lib/Semantics/check-case.h | 30 ++++ flang/lib/Semantics/semantics.cpp | 41 +++--- flang/test/Semantics/case01.f90 | 165 +++++++++++++++++++++ 7 files changed, 528 insertions(+), 42 deletions(-) create mode 100644 flang/lib/Semantics/check-case.cpp create mode 100644 flang/lib/Semantics/check-case.h create mode 100644 flang/test/Semantics/case01.f90 diff --git a/flang/include/flang/Evaluate/integer.h b/flang/include/flang/Evaluate/integer.h index 6f997c96..f519c2e 100644 --- a/flang/include/flang/Evaluate/integer.h +++ b/flang/include/flang/Evaluate/integer.h @@ -49,7 +49,7 @@ namespace Fortran::evaluate::value { // Member functions that correspond to Fortran intrinsic functions are // named accordingly in ALL CAPS so that they can be referenced easily in // the language standard. -template, typename BIGPART = HostUnsignedInt> @@ -110,13 +110,13 @@ public: }; // Constructors and value-generating static functions - constexpr Integer() { Clear(); } // default constructor: zero + constexpr Integer() { Clear(); } // default constructor: zero constexpr Integer(const Integer &) = default; constexpr Integer(Integer &&) = default; // C++'s integral types can all be converted to Integer // with silent truncation. - template>> + template >> constexpr Integer(INT n) { constexpr int nBits = CHAR_BIT * sizeof n; if constexpr (nBits < partBits) { @@ -175,12 +175,24 @@ public: constexpr Integer &operator=(const Integer &) = default; + constexpr bool operator<(const Integer &that) const { + return CompareUnsigned(that) == Ordering::Less; + } + constexpr bool operator<=(const Integer &that) const { + return CompareUnsigned(that) != Ordering::Greater; + } constexpr bool operator==(const Integer &that) const { return CompareUnsigned(that) == Ordering::Equal; } constexpr bool operator!=(const Integer &that) const { return !(*this == that); } + constexpr bool operator>=(const Integer &that) const { + return CompareUnsigned(that) != Ordering::Less; + } + constexpr bool operator>(const Integer &that) const { + return CompareUnsigned(that) == Ordering::Greater; + } // Left-justified mask (e.g., MASKL(1) has only its sign bit set) static constexpr Integer MASKL(int places) { @@ -265,7 +277,7 @@ public: return {result, overflow}; } - template + template static constexpr ValueWithOverflow ConvertUnsigned(const FROM &that) { std::uint64_t field{that.ToUInt64()}; ValueWithOverflow result{field, false}; @@ -286,7 +298,7 @@ public: return result; } - template + template static constexpr ValueWithOverflow ConvertSigned(const FROM &that) { ValueWithOverflow result{ConvertUnsigned(that)}; if constexpr (bits > FROM::bits) { @@ -344,7 +356,7 @@ public: return result; } - static constexpr int DIGITS{bits - 1}; // don't count the sign bit + static constexpr int DIGITS{bits - 1}; // don't count the sign bit static constexpr Integer HUGE() { return MASKR(bits - 1); } static constexpr int RANGE{// in the sense of SELECTED_INT_KIND // This magic value is LOG10(2.)*1E12. @@ -404,9 +416,9 @@ public: constexpr bool POPPAR() const { return POPCNT() & 1; } constexpr int TRAILZ() const { - auto minus1{AddUnsigned(MASKR(bits))}; // { x-1, carry = x > 0 } + auto minus1{AddUnsigned(MASKR(bits))}; // { x-1, carry = x > 0 } if (!minus1.carry) { - return bits; // was zero + return bits; // was zero } else { // x ^ (x-1) has all bits set at and below original least-order set bit. return IEOR(minus1.value).POPCNT() - 1; @@ -786,7 +798,7 @@ public: } constexpr Product MultiplyUnsigned(const Integer &y) const { - Part product[2 * parts]{}; // little-endian full product + Part product[2 * parts]{}; // little-endian full product for (int j{0}; j < parts; ++j) { if (Part xpart{LEPart(j)}) { for (int k{0}; k < parts; ++k) { @@ -842,7 +854,7 @@ public: constexpr QuotientWithRemainder DivideUnsigned(const Integer &divisor) const { if (divisor.IsZero()) { - return {MASKR(bits), Integer{}, true, false}; // overflow to max value + return {MASKR(bits), Integer{}, true, false}; // overflow to max value } int bitsDone{LEADZ()}; Integer top{SHIFTL(bitsDone)}; @@ -942,13 +954,13 @@ public: result.divisionByZero = true; result.power = MASKR(bits - 1); } else if (CompareSigned(Integer{1}) == Ordering::Equal) { - result.power = *this; // 1**x -> 1 + result.power = *this; // 1**x -> 1 } else if (CompareSigned(Integer{-1}) == Ordering::Equal) { if (exponent.BTEST(0)) { - result.power = *this; // (-1)**x -> -1 if x is odd + result.power = *this; // (-1)**x -> -1 if x is odd } } else { - result.power.Clear(); // j**k -> 0 if |j| > 1 and k < 0 + result.power.Clear(); // j**k -> 0 if |j| > 1 and k < 0 } } else { Integer shifted{*this}; @@ -1016,5 +1028,5 @@ extern template class Integer<32>; extern template class Integer<64>; extern template class Integer<80>; extern template class Integer<128>; -} -#endif // FORTRAN_EVALUATE_INTEGER_H_ +} // namespace Fortran::evaluate::value +#endif // FORTRAN_EVALUATE_INTEGER_H_ diff --git a/flang/include/flang/Evaluate/logical.h b/flang/include/flang/Evaluate/logical.h index a7813ec..44ba30a 100644 --- a/flang/include/flang/Evaluate/logical.h +++ b/flang/include/flang/Evaluate/logical.h @@ -14,7 +14,7 @@ namespace Fortran::evaluate::value { -template class Logical { +template class Logical { public: static constexpr int bits{BITS}; @@ -22,19 +22,43 @@ public: // C's bit representation (.TRUE. -> 1, .FALSE. -> 0). static constexpr bool IsLikeC{BITS <= 8 || IS_LIKE_C}; - constexpr Logical() {} // .FALSE. - template + constexpr Logical() {} // .FALSE. + template constexpr Logical(Logical x) : word_{Represent(x.IsTrue())} {} constexpr Logical(bool truth) : word_{Represent(truth)} {} - template constexpr Logical &operator=(Logical x) { + template constexpr Logical &operator=(Logical x) { word_ = Represent(x.IsTrue()); } - template + // Fortran actually has only .EQV. & .NEQV. relational operations + // for LOGICAL, but this template class supports more so that + // it can be used with the STL for sorting and as a key type for + // std::set<> & std::map<>. + template + constexpr bool operator<(const Logical &that) const { + return !IsTrue() && that.IsTrue(); + } + template + constexpr bool operator<=(const Logical &) const { + return !IsTrue(); + } + template constexpr bool operator==(const Logical &that) const { return IsTrue() == that.IsTrue(); } + template + constexpr bool operator!=(const Logical &that) const { + return IsTrue() != that.IsTrue(); + } + template + constexpr bool operator>=(const Logical &) const { + return IsTrue(); + } + template + constexpr bool operator>(const Logical &that) const { + return IsTrue() && !that.IsTrue(); + } constexpr bool IsTrue() const { if constexpr (IsLikeC) { @@ -75,5 +99,5 @@ extern template class Logical<8>; extern template class Logical<16>; extern template class Logical<32>; extern template class Logical<64>; -} -#endif // FORTRAN_EVALUATE_LOGICAL_H_ +} // namespace Fortran::evaluate::value +#endif // FORTRAN_EVALUATE_LOGICAL_H_ diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt index 1ca03d0..feedbab 100644 --- a/flang/lib/Semantics/CMakeLists.txt +++ b/flang/lib/Semantics/CMakeLists.txt @@ -7,6 +7,7 @@ add_library(FortranSemantics check-allocate.cpp check-arithmeticif.cpp check-call.cpp + check-case.cpp check-coarray.cpp check-data.cpp check-deallocate.cpp diff --git a/flang/lib/Semantics/check-case.cpp b/flang/lib/Semantics/check-case.cpp new file mode 100644 index 0000000..c0f957a --- /dev/null +++ b/flang/lib/Semantics/check-case.cpp @@ -0,0 +1,253 @@ +//===-- lib/Semantics/check-case.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-case.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 + +namespace Fortran::semantics { + +template class CaseValues { +public: + CaseValues(SemanticsContext &c, const evaluate::DynamicType &t) + : context_{c}, caseExprType_{t} {} + + void Check(const std::list &cases) { + for (const parser::CaseConstruct::Case &c : cases) { + AddCase(c); + } + if (!hasErrors_) { + cases_.sort(Comparator{}); + if (!AreCasesDisjoint()) { // C1149 + ReportConflictingCases(); + } + } + } + +private: + using Value = evaluate::Scalar; + + void AddCase(const parser::CaseConstruct::Case &c) { + const auto &stmt{std::get>(c.t)}; + const parser::CaseStmt &caseStmt{stmt.statement}; + const auto &selector{std::get(caseStmt.t)}; + std::visit( + common::visitors{ + [&](const std::list &ranges) { + for (const auto &range : ranges) { + auto pair{ComputeBounds(range)}; + if (pair.first && pair.second && *pair.first > *pair.second) { + context_.Say(stmt.source, + "CASE has lower bound greater than upper bound"_en_US); + } else { + if constexpr (T::category == TypeCategory::Logical) { // C1148 + if ((pair.first || pair.second) && + (!pair.first || !pair.second || + *pair.first != *pair.second)) { + context_.Say(stmt.source, + "CASE range is not allowed for LOGICAL"_err_en_US); + } + } + cases_.emplace_back(stmt); + cases_.back().lower = std::move(pair.first); + cases_.back().upper = std::move(pair.second); + } + } + }, + [&](const parser::Default &) { cases_.emplace_front(stmt); }, + }, + selector.u); + } + + std::optional GetValue(const parser::CaseValue &caseValue) { + const parser::Expr &expr{caseValue.thing.thing.value()}; + auto *x{expr.typedExpr.get()}; + if (x && x->v) { // C1147 + auto type{x->v->GetType()}; + if (type && type->category() == caseExprType_.category() && + (type->category() != TypeCategory::Character || + type->kind() == caseExprType_.kind())) { + x->v = evaluate::Fold(context_.foldingContext(), + evaluate::ConvertToType(T::GetType(), std::move(*x->v))); + if (x->v) { + if (auto value{evaluate::GetScalarConstantValue(*x->v)}) { + return *value; + } + } + context_.Say( + expr.source, "CASE value must be a constant scalar"_err_en_US); + } else { + std::string typeStr{type ? type->AsFortran() : "typeless"s}; + context_.Say(expr.source, + "CASE value has type '%s' which is not compatible with the SELECT CASE expression's type '%s'"_err_en_US, + typeStr, caseExprType_.AsFortran()); + } + hasErrors_ = true; + } + return std::nullopt; + } + + using PairOfValues = std::pair, std::optional>; + PairOfValues ComputeBounds(const parser::CaseValueRange &range) { + return std::visit( + common::visitors{ + [&](const parser::CaseValue &x) { + auto value{GetValue(x)}; + return PairOfValues{value, value}; + }, + [&](const parser::CaseValueRange::Range &x) { + std::optional lo, hi; + if (x.lower) { + lo = GetValue(*x.lower); + } + if (x.upper) { + hi = GetValue(*x.upper); + } + if ((x.lower && !lo) || (x.upper && !hi)) { + return PairOfValues{}; // error case + } + return PairOfValues{std::move(lo), std::move(hi)}; + }, + }, + range.u); + } + + struct Case { + explicit Case(const parser::Statement &s) : stmt{s} {} + bool IsDefault() const { return !lower && !upper; } + std::string AsFortran() const { + std::string result; + { + llvm::raw_string_ostream bs{result}; + if (lower) { + evaluate::Constant{*lower}.AsFortran(bs << '('); + if (!upper) { + bs << ':'; + } else if (*lower != *upper) { + evaluate::Constant{*upper}.AsFortran(bs << ':'); + } + bs << ')'; + } else if (upper) { + evaluate::Constant{*upper}.AsFortran(bs << "(:") << ')'; + } else { + bs << "DEFAULT"; + } + } + return result; + } + + const parser::Statement &stmt; + std::optional lower, upper; + }; + + // Defines a comparator for use with std::list<>::sort(). + // Returns true if and only if the highest value in range x is less + // than the least value in range y. The DEFAULT case is arbitrarily + // defined to be less than all others. When two ranges overlap, + // neither is less than the other. + struct Comparator { + bool operator()(const Case &x, const Case &y) const { + if (x.IsDefault()) { + return !y.IsDefault(); + } else { + return x.upper && y.lower && *x.upper < *y.lower; + } + } + }; + + bool AreCasesDisjoint() const { + auto endIter{cases_.end()}; + for (auto iter{cases_.begin()}; iter != endIter; ++iter) { + auto next{iter}; + if (++next != endIter && !Comparator{}(*iter, *next)) { + return false; + } + } + return true; + } + + // This has quadratic time, but only runs in error cases + void ReportConflictingCases() { + for (auto iter{cases_.begin()}; iter != cases_.end(); ++iter) { + parser::Message *msg{nullptr}; + for (auto p{cases_.begin()}; p != cases_.end(); ++p) { + if (p->stmt.source.begin() < iter->stmt.source.begin() && + !Comparator{}(*p, *iter) && !Comparator{}(*iter, *p)) { + if (!msg) { + msg = &context_.Say(iter->stmt.source, + "CASE %s conflicts with previous cases"_err_en_US, + iter->AsFortran()); + } + msg->Attach( + p->stmt.source, "Conflicting CASE %s"_en_US, p->AsFortran()); + } + } + } + } + + SemanticsContext &context_; + const evaluate::DynamicType &caseExprType_; + std::list cases_; + bool hasErrors_{false}; +}; + +void CaseChecker::Enter(const parser::CaseConstruct &construct) { + const auto &selectCaseStmt{ + std::get>(construct.t)}; + const auto &selectCase{selectCaseStmt.statement}; + const auto &selectExpr{ + std::get>(selectCase.t).thing}; + const auto *x{GetExpr(selectExpr)}; + if (!x) { + return; // expression semantics failed + } + if (auto exprType{x->GetType()}) { + const auto &caseList{ + std::get>(construct.t)}; + switch (exprType->category()) { + case TypeCategory::Integer: + CaseValues>{context_, *exprType} + .Check(caseList); + return; + case TypeCategory::Logical: + CaseValues>{context_, *exprType} + .Check(caseList); + return; + case TypeCategory::Character: + switch (exprType->kind()) { + SWITCH_COVERS_ALL_CASES + case 1: + CaseValues>{ + context_, *exprType} + .Check(caseList); + return; + case 2: + CaseValues>{ + context_, *exprType} + .Check(caseList); + return; + case 4: + CaseValues>{ + context_, *exprType} + .Check(caseList); + return; + } + default: + break; + } + } + context_.Say(selectExpr.source, + "SELECT CASE expression must be integer, logical, or character"_err_en_US); +} +} // namespace Fortran::semantics diff --git a/flang/lib/Semantics/check-case.h b/flang/lib/Semantics/check-case.h new file mode 100644 index 0000000..6abd6c6 --- /dev/null +++ b/flang/lib/Semantics/check-case.h @@ -0,0 +1,30 @@ +//===-- lib/Semantics/check-case.h ------------------------------*- C++ -*-===// +// +// 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_SEMANTICS_CHECK_CASE_H_ +#define FORTRAN_SEMANTICS_CHECK_CASE_H_ + +#include "flang/Semantics/semantics.h" + +namespace Fortran::parser { +struct CaseConstruct; +} + +namespace Fortran::semantics { + +class CaseChecker : public virtual BaseChecker { +public: + explicit CaseChecker(SemanticsContext &context) : context_{context} {}; + + void Enter(const parser::CaseConstruct &); + +private: + SemanticsContext &context_; +}; +} // namespace Fortran::semantics +#endif // FORTRAN_SEMANTICS_CHECK_CASE_H_ diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp index 340c0a9..406396b 100644 --- a/flang/lib/Semantics/semantics.cpp +++ b/flang/lib/Semantics/semantics.cpp @@ -12,6 +12,7 @@ #include "canonicalize-omp.h" #include "check-allocate.h" #include "check-arithmeticif.h" +#include "check-case.h" #include "check-coarray.h" #include "check-data.h" #include "check-deallocate.h" @@ -61,44 +62,44 @@ static void GetSymbolNames(const Scope &scope, NameToSymbolMap &symbols) { // children are visited, Leave is called after. No two checkers may have the // same Enter or Leave function. Each checker must be constructible from // SemanticsContext and have BaseChecker as a virtual base class. -template class SemanticsVisitor : public virtual C... { +template class SemanticsVisitor : public virtual C... { public: using C::Enter...; using C::Leave...; using BaseChecker::Enter; using BaseChecker::Leave; SemanticsVisitor(SemanticsContext &context) - : C{context}..., context_{context} {} + : C{context}..., context_{context} {} - template bool Pre(const N &node) { + template bool Pre(const N &node) { if constexpr (common::HasMember) { context_.PushConstruct(node); } Enter(node); return true; } - template void Post(const N &node) { + template void Post(const N &node) { Leave(node); if constexpr (common::HasMember) { context_.PopConstruct(); } } - template bool Pre(const parser::Statement &node) { + template bool Pre(const parser::Statement &node) { context_.set_location(node.source); Enter(node); return true; } - template bool Pre(const parser::UnlabeledStatement &node) { + template bool Pre(const parser::UnlabeledStatement &node) { context_.set_location(node.source); Enter(node); return true; } - template void Post(const parser::Statement &node) { + template void Post(const parser::Statement &node) { Leave(node); context_.set_location(std::nullopt); } - template void Post(const parser::UnlabeledStatement &node) { + template void Post(const parser::UnlabeledStatement &node) { Leave(node); context_.set_location(std::nullopt); } @@ -116,7 +117,7 @@ class EntryChecker : public virtual BaseChecker { public: explicit EntryChecker(SemanticsContext &context) : context_{context} {} void Leave(const parser::EntryStmt &) { - if (!context_.constructStack().empty()) { // C1571 + if (!context_.constructStack().empty()) { // C1571 context_.Say("ENTRY may not appear in an executable construct"_err_en_US); } } @@ -127,10 +128,10 @@ private: using StatementSemanticsPass1 = ExprChecker; using StatementSemanticsPass2 = SemanticsVisitor; + ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker, + DataChecker, DeallocateChecker, DoForallChecker, EntryChecker, + IfStmtChecker, IoChecker, NamelistChecker, NullifyChecker, + OmpStructureChecker, PurityChecker, ReturnStmtChecker, StopChecker>; static bool PerformStatementSemantics( SemanticsContext &context, parser::Program &program) { @@ -146,11 +147,11 @@ SemanticsContext::SemanticsContext( const common::IntrinsicTypeDefaultKinds &defaultKinds, const common::LanguageFeatureControl &languageFeatures, parser::AllSources &allSources) - : defaultKinds_{defaultKinds}, languageFeatures_{languageFeatures}, - allSources_{allSources}, - intrinsics_{evaluate::IntrinsicProcTable::Configure(defaultKinds_)}, - foldingContext_{ - parser::ContextualMessages{&messages_}, defaultKinds_, intrinsics_} {} + : defaultKinds_{defaultKinds}, languageFeatures_{languageFeatures}, + allSources_{allSources}, + intrinsics_{evaluate::IntrinsicProcTable::Configure(defaultKinds_)}, + foldingContext_{ + parser::ContextualMessages{&messages_}, defaultKinds_, intrinsics_} {} SemanticsContext::~SemanticsContext() {} @@ -290,7 +291,7 @@ SymbolVector SemanticsContext::GetIndexVars(IndexVarKind kind) { bool Semantics::Perform() { return ValidateLabels(context_, program_) && - parser::CanonicalizeDo(program_) && // force line break + parser::CanonicalizeDo(program_) && // force line break CanonicalizeOmp(context_.messages(), program_) && PerformStatementSemantics(context_, program_) && ModFileWriter{context_}.WriteAll(); @@ -376,4 +377,4 @@ static void PutIndent(llvm::raw_ostream &os, int indent) { os << " "; } } -} +} // namespace Fortran::semantics diff --git a/flang/test/Semantics/case01.f90 b/flang/test/Semantics/case01.f90 new file mode 100644 index 0000000..7e5efc6 --- /dev/null +++ b/flang/test/Semantics/case01.f90 @@ -0,0 +1,165 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +! Test SELECT CASE Constraints: C1145, C1146, C1147, C1148, C1149 +program selectCaseProg + implicit none + ! local variable declaration + character :: grade1 = 'B' + integer :: grade2 = 3 + logical :: grade3 = .false. + real :: grade4 = 2.0 + character (len = 10) :: name = 'test' + logical, parameter :: grade5 = .false. + CHARACTER(KIND=1), parameter :: ASCII_parm1 = 'a', ASCII_parm2='b' + CHARACTER(KIND=2), parameter :: UCS16_parm = 'c' + CHARACTER(KIND=4), parameter :: UCS32_parm ='d' + type scores + integer :: val + end type + type (scores) :: score = scores(25) + type (scores), parameter :: score_val = scores(50) + + ! Valid Cases + select case (grade1) + case ('A') + case ('B') + case ('C') + case default + end select + + select case (grade2) + case (1) + case (2) + case (3) + case default + end select + + select case (grade3) + case (.true.) + case (.false.) + end select + + select case (name) + case default + case ('now') + case ('test') + end select + + ! C1145 + !ERROR: SELECT CASE expression must be integer, logical, or character + select case (grade4) + case (1.0) + case (2.0) + case (3.0) + case default + end select + + !ERROR: SELECT CASE expression must be integer, logical, or character + select case (score) + case (score_val) + case (scores(100)) + end select + + ! C1146 + select case (grade3) + case default + case (.true.) + !ERROR: CASE DEFAULT conflicts with previous cases + case default + end select + + ! C1147 + select case (grade2) + !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + case (:'Z') + case default + end select + + select case (grade1) + !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)' + case (:1) + case default + end select + + select case (grade3) + case default + case (.true.) + !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'LOGICAL(4)' + case (3) + end select + + select case (grade2) + case default + case (2 :) + !ERROR: CASE value has type 'LOGICAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + case (.true. :) + !ERROR: CASE value has type 'REAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + case (1.0) + !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)' + case ('wow') + end select + + select case (ASCII_parm1) + case (ASCII_parm2) + !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + case (UCS32_parm) + !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + case (UCS16_parm) + !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + case (4_"ucs-32") + !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)' + case (2_"ucs-16") + case default + end select + + ! C1148 + select case (grade3) + case default + !ERROR: CASE range is not allowed for LOGICAL + case (.true. :) + end select + + ! C1149 + select case (grade3) + case (.true.) + case (.false.) + !ERROR: CASE (.true._1) conflicts with previous cases + case (.true.) + !ERROR: CASE (.false._1) conflicts with previous cases + case (grade5) + end select + + select case (grade2) + case (51:50) ! warning + case (100:) + case (:30) + case (40) + case (90) + case (91:99) + !ERROR: CASE (81_16:90_16) conflicts with previous cases + case (81:90) + !ERROR: CASE (:80_16) conflicts with previous cases + case (:80) + !ERROR: CASE (200_16) conflicts with previous cases + case (200) + case default + end select + + select case (name) + case ('hello') + case ('hey') + !ERROR: CASE (:"hh") conflicts with previous cases + case (:'hh') + !ERROR: CASE (:"hd") conflicts with previous cases + case (:'hd') + case ( 'hu':) + case ('hi':'ho') + !ERROR: CASE ("hj") conflicts with previous cases + case ('hj') + !ERROR: CASE ("ha") conflicts with previous cases + case ('ha') + !ERROR: CASE ("hz") conflicts with previous cases + case ('hz') + case default + end select + +end program -- 2.7.4