forked from OSchip/llvm-project
[flang] Semantics for SELECT CASE
Prep for review Respond to review comments Fix first line in new test Original-commit: flang-compiler/f18@12f6f30600 Reviewed-on: https://github.com/flang-compiler/f18/pull/1089
This commit is contained in:
peter klausler
parent
282358fac9
commit
7a77c20dbd
|
|
@ -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<int BITS, bool IS_LITTLE_ENDIAN = isHostLittleEndian,
|
||||
template <int BITS, bool IS_LITTLE_ENDIAN = isHostLittleEndian,
|
||||
int PARTBITS = BITS <= 32 ? BITS : 32,
|
||||
typename PART = HostUnsignedInt<PARTBITS>,
|
||||
typename BIGPART = HostUnsignedInt<PARTBITS * 2>>
|
||||
|
|
@ -116,7 +116,7 @@ public:
|
|||
|
||||
// C++'s integral types can all be converted to Integer
|
||||
// with silent truncation.
|
||||
template<typename INT, typename = std::enable_if_t<std::is_integral_v<INT>>>
|
||||
template <typename INT, typename = std::enable_if_t<std::is_integral_v<INT>>>
|
||||
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<typename FROM>
|
||||
template <typename FROM>
|
||||
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<typename FROM>
|
||||
template <typename FROM>
|
||||
static constexpr ValueWithOverflow ConvertSigned(const FROM &that) {
|
||||
ValueWithOverflow result{ConvertUnsigned(that)};
|
||||
if constexpr (bits > FROM::bits) {
|
||||
|
|
@ -1016,5 +1028,5 @@ extern template class Integer<32>;
|
|||
extern template class Integer<64>;
|
||||
extern template class Integer<80>;
|
||||
extern template class Integer<128>;
|
||||
}
|
||||
} // namespace Fortran::evaluate::value
|
||||
#endif // FORTRAN_EVALUATE_INTEGER_H_
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
namespace Fortran::evaluate::value {
|
||||
|
||||
template<int BITS, bool IS_LIKE_C = true> class Logical {
|
||||
template <int BITS, bool IS_LIKE_C = true> class Logical {
|
||||
public:
|
||||
static constexpr int bits{BITS};
|
||||
|
||||
|
|
@ -23,18 +23,42 @@ public:
|
|||
static constexpr bool IsLikeC{BITS <= 8 || IS_LIKE_C};
|
||||
|
||||
constexpr Logical() {} // .FALSE.
|
||||
template<int B, bool C>
|
||||
template <int B, bool C>
|
||||
constexpr Logical(Logical<B, C> x) : word_{Represent(x.IsTrue())} {}
|
||||
constexpr Logical(bool truth) : word_{Represent(truth)} {}
|
||||
|
||||
template<int B, bool C> constexpr Logical &operator=(Logical<B, C> x) {
|
||||
template <int B, bool C> constexpr Logical &operator=(Logical<B, C> x) {
|
||||
word_ = Represent(x.IsTrue());
|
||||
}
|
||||
|
||||
template<int B, bool C>
|
||||
// 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 <int B, bool C>
|
||||
constexpr bool operator<(const Logical<B, C> &that) const {
|
||||
return !IsTrue() && that.IsTrue();
|
||||
}
|
||||
template <int B, bool C>
|
||||
constexpr bool operator<=(const Logical<B, C> &) const {
|
||||
return !IsTrue();
|
||||
}
|
||||
template <int B, bool C>
|
||||
constexpr bool operator==(const Logical<B, C> &that) const {
|
||||
return IsTrue() == that.IsTrue();
|
||||
}
|
||||
template <int B, bool C>
|
||||
constexpr bool operator!=(const Logical<B, C> &that) const {
|
||||
return IsTrue() != that.IsTrue();
|
||||
}
|
||||
template <int B, bool C>
|
||||
constexpr bool operator>=(const Logical<B, C> &) const {
|
||||
return IsTrue();
|
||||
}
|
||||
template <int B, bool C>
|
||||
constexpr bool operator>(const Logical<B, C> &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>;
|
||||
}
|
||||
} // namespace Fortran::evaluate::value
|
||||
#endif // FORTRAN_EVALUATE_LOGICAL_H_
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <tuple>
|
||||
|
||||
namespace Fortran::semantics {
|
||||
|
||||
template <typename T> class CaseValues {
|
||||
public:
|
||||
CaseValues(SemanticsContext &c, const evaluate::DynamicType &t)
|
||||
: context_{c}, caseExprType_{t} {}
|
||||
|
||||
void Check(const std::list<parser::CaseConstruct::Case> &cases) {
|
||||
for (const parser::CaseConstruct::Case &c : cases) {
|
||||
AddCase(c);
|
||||
}
|
||||
if (!hasErrors_) {
|
||||
cases_.sort(Comparator{});
|
||||
if (!AreCasesDisjoint()) { // C1149
|
||||
ReportConflictingCases();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
private:
|
||||
using Value = evaluate::Scalar<T>;
|
||||
|
||||
void AddCase(const parser::CaseConstruct::Case &c) {
|
||||
const auto &stmt{std::get<parser::Statement<parser::CaseStmt>>(c.t)};
|
||||
const parser::CaseStmt &caseStmt{stmt.statement};
|
||||
const auto &selector{std::get<parser::CaseSelector>(caseStmt.t)};
|
||||
std::visit(
|
||||
common::visitors{
|
||||
[&](const std::list<parser::CaseValueRange> &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<Value> 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<T>(*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<Value>, std::optional<Value>>;
|
||||
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<Value> 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<parser::CaseStmt> &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<T>{*lower}.AsFortran(bs << '(');
|
||||
if (!upper) {
|
||||
bs << ':';
|
||||
} else if (*lower != *upper) {
|
||||
evaluate::Constant<T>{*upper}.AsFortran(bs << ':');
|
||||
}
|
||||
bs << ')';
|
||||
} else if (upper) {
|
||||
evaluate::Constant<T>{*upper}.AsFortran(bs << "(:") << ')';
|
||||
} else {
|
||||
bs << "DEFAULT";
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
const parser::Statement<parser::CaseStmt> &stmt;
|
||||
std::optional<Value> 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<Case> cases_;
|
||||
bool hasErrors_{false};
|
||||
};
|
||||
|
||||
void CaseChecker::Enter(const parser::CaseConstruct &construct) {
|
||||
const auto &selectCaseStmt{
|
||||
std::get<parser::Statement<parser::SelectCaseStmt>>(construct.t)};
|
||||
const auto &selectCase{selectCaseStmt.statement};
|
||||
const auto &selectExpr{
|
||||
std::get<parser::Scalar<parser::Expr>>(selectCase.t).thing};
|
||||
const auto *x{GetExpr(selectExpr)};
|
||||
if (!x) {
|
||||
return; // expression semantics failed
|
||||
}
|
||||
if (auto exprType{x->GetType()}) {
|
||||
const auto &caseList{
|
||||
std::get<std::list<parser::CaseConstruct::Case>>(construct.t)};
|
||||
switch (exprType->category()) {
|
||||
case TypeCategory::Integer:
|
||||
CaseValues<evaluate::Type<TypeCategory::Integer, 16>>{context_, *exprType}
|
||||
.Check(caseList);
|
||||
return;
|
||||
case TypeCategory::Logical:
|
||||
CaseValues<evaluate::Type<TypeCategory::Logical, 1>>{context_, *exprType}
|
||||
.Check(caseList);
|
||||
return;
|
||||
case TypeCategory::Character:
|
||||
switch (exprType->kind()) {
|
||||
SWITCH_COVERS_ALL_CASES
|
||||
case 1:
|
||||
CaseValues<evaluate::Type<TypeCategory::Character, 1>>{
|
||||
context_, *exprType}
|
||||
.Check(caseList);
|
||||
return;
|
||||
case 2:
|
||||
CaseValues<evaluate::Type<TypeCategory::Character, 2>>{
|
||||
context_, *exprType}
|
||||
.Check(caseList);
|
||||
return;
|
||||
case 4:
|
||||
CaseValues<evaluate::Type<TypeCategory::Character, 4>>{
|
||||
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
|
||||
|
|
@ -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_
|
||||
|
|
@ -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,7 +62,7 @@ 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<typename... C> class SemanticsVisitor : public virtual C... {
|
||||
template <typename... C> class SemanticsVisitor : public virtual C... {
|
||||
public:
|
||||
using C::Enter...;
|
||||
using C::Leave...;
|
||||
|
|
@ -70,35 +71,35 @@ public:
|
|||
SemanticsVisitor(SemanticsContext &context)
|
||||
: C{context}..., context_{context} {}
|
||||
|
||||
template<typename N> bool Pre(const N &node) {
|
||||
template <typename N> bool Pre(const N &node) {
|
||||
if constexpr (common::HasMember<const N *, ConstructNode>) {
|
||||
context_.PushConstruct(node);
|
||||
}
|
||||
Enter(node);
|
||||
return true;
|
||||
}
|
||||
template<typename N> void Post(const N &node) {
|
||||
template <typename N> void Post(const N &node) {
|
||||
Leave(node);
|
||||
if constexpr (common::HasMember<const N *, ConstructNode>) {
|
||||
context_.PopConstruct();
|
||||
}
|
||||
}
|
||||
|
||||
template<typename T> bool Pre(const parser::Statement<T> &node) {
|
||||
template <typename T> bool Pre(const parser::Statement<T> &node) {
|
||||
context_.set_location(node.source);
|
||||
Enter(node);
|
||||
return true;
|
||||
}
|
||||
template<typename T> bool Pre(const parser::UnlabeledStatement<T> &node) {
|
||||
template <typename T> bool Pre(const parser::UnlabeledStatement<T> &node) {
|
||||
context_.set_location(node.source);
|
||||
Enter(node);
|
||||
return true;
|
||||
}
|
||||
template<typename T> void Post(const parser::Statement<T> &node) {
|
||||
template <typename T> void Post(const parser::Statement<T> &node) {
|
||||
Leave(node);
|
||||
context_.set_location(std::nullopt);
|
||||
}
|
||||
template<typename T> void Post(const parser::UnlabeledStatement<T> &node) {
|
||||
template <typename T> void Post(const parser::UnlabeledStatement<T> &node) {
|
||||
Leave(node);
|
||||
context_.set_location(std::nullopt);
|
||||
}
|
||||
|
|
@ -127,10 +128,10 @@ private:
|
|||
|
||||
using StatementSemanticsPass1 = ExprChecker;
|
||||
using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
|
||||
ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker, DataChecker,
|
||||
DeallocateChecker, DoForallChecker, EntryChecker, IfStmtChecker, IoChecker,
|
||||
NamelistChecker, NullifyChecker, OmpStructureChecker, PurityChecker,
|
||||
ReturnStmtChecker, StopChecker>;
|
||||
ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker,
|
||||
DataChecker, DeallocateChecker, DoForallChecker, EntryChecker,
|
||||
IfStmtChecker, IoChecker, NamelistChecker, NullifyChecker,
|
||||
OmpStructureChecker, PurityChecker, ReturnStmtChecker, StopChecker>;
|
||||
|
||||
static bool PerformStatementSemantics(
|
||||
SemanticsContext &context, parser::Program &program) {
|
||||
|
|
@ -376,4 +377,4 @@ static void PutIndent(llvm::raw_ostream &os, int indent) {
|
|||
os << " ";
|
||||
}
|
||||
}
|
||||
}
|
||||
} // namespace Fortran::semantics
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue