[flang-commits] [flang] 70ad73b - [flang] Semantics for SELECT TYPE
Sameeran joshi via flang-commits
flang-commits at lists.llvm.org
Thu Jun 11 11:44:03 PDT 2020
Author: sameeran joshi
Date: 2020-06-12T00:12:24+05:30
New Revision: 70ad73b6b76838bd7c72123922102b175e5d478a
URL: https://github.com/llvm/llvm-project/commit/70ad73b6b76838bd7c72123922102b175e5d478a
DIFF: https://github.com/llvm/llvm-project/commit/70ad73b6b76838bd7c72123922102b175e5d478a.diff
LOG: [flang] Semantics for SELECT TYPE
Summary:
Added support for all semantic checks except C1157
was previously implemented.
Address review comments.
Reviewers: PeteSteinfeld, tskeith, klausler, DavidTruby, kiranktp, anchu-rajendran, sscalpone
Subscribers: kiranchandramohan, llvm-commits, flang-commits
Tags: #llvm, #flang
Differential Revision: https://reviews.llvm.org/D79851
Added:
flang/lib/Semantics/check-select-type.cpp
flang/lib/Semantics/check-select-type.h
flang/test/Semantics/selecttype01.f90
flang/test/Semantics/selecttype02.f90
flang/test/Semantics/selecttype03.f90
Modified:
flang/lib/Semantics/CMakeLists.txt
flang/lib/Semantics/assignment.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/semantics.cpp
Removed:
################################################################################
diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt
index ff2eba6d12e0..4fd75bc60f00 100644
--- a/flang/lib/Semantics/CMakeLists.txt
+++ b/flang/lib/Semantics/CMakeLists.txt
@@ -21,6 +21,7 @@ add_flang_library(FortranSemantics
check-purity.cpp
check-return.cpp
check-select-rank.cpp
+ check-select-type.cpp
check-stop.cpp
compute-offsets.cpp
expression.cpp
diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp
index 657e618c1d7e..ab8f5e4fdf56 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -75,7 +75,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
const Scope &scope{context_.FindScope(lhsLoc)};
if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) {
if (auto *msg{Say(lhsLoc,
- "Left-hand side of assignment is not modifiable"_err_en_US)}) {
+ "Left-hand side of assignment is not modifiable"_err_en_US)}) { // C1158
msg->Attach(*whyNot);
}
}
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 163944533eac..282a8776103a 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -332,7 +332,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (auto why{WhyNotModifiable(
messages.at(), actual, *scope, vectorSubscriptIsOk)}) {
if (auto *msg{messages.Say(
- "Actual argument associated with %s %s must be definable"_err_en_US,
+ "Actual argument associated with %s %s must be definable"_err_en_US, // C1158
reason, dummyName)}) {
msg->Attach(*why);
}
diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp
new file mode 100644
index 000000000000..5b430440dffb
--- /dev/null
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -0,0 +1,262 @@
+//===-- 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(guard, *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::TypeGuardStmt::Guard &guard,
+ const evaluate::DynamicType &guardDynamicType) {
+ return std::visit(
+ common::visitors{
+ [](const parser::Default &) { return true; },
+ [&](const parser::TypeSpec &typeSpec) {
+ if (const DeclTypeSpec * spec{typeSpec.declTypeSpec}) {
+ 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);
+ return false;
+ }
+ if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
+ return PassesDerivedTypeChecks(
+ *derived, parser::FindSourceLocation(typeSpec));
+ }
+ return false;
+ }
+ return false;
+ },
+ [&](const parser::DerivedTypeSpec &x) {
+ if (const semantics::DerivedTypeSpec *
+ derived{x.derivedTypeSpec}) {
+ return PassesDerivedTypeChecks(
+ *derived, parser::FindSourceLocation(x));
+ }
+ return false;
+ },
+ },
+ 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
diff erent
+ // 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
diff --git a/flang/lib/Semantics/check-select-type.h b/flang/lib/Semantics/check-select-type.h
new file mode 100644
index 000000000000..87b58e7c2265
--- /dev/null
+++ b/flang/lib/Semantics/check-select-type.h
@@ -0,0 +1,31 @@
+//===-- lib/Semantics/check-select-type.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_SELECT_TYPE_H_
+#define FORTRAN_SEMANTICS_CHECK_SELECT_TYPE_H_
+
+#include "flang/Semantics/semantics.h"
+
+namespace Fortran::parser {
+struct SelectTypeConstruct;
+struct Selector;
+} // namespace Fortran::parser
+
+namespace Fortran::semantics {
+
+class SelectTypeChecker : public virtual BaseChecker {
+public:
+ explicit SelectTypeChecker(SemanticsContext &context) : context_{context} {};
+ void Enter(const parser::SelectTypeConstruct &);
+
+private:
+ const SomeExpr *GetExprFromSelector(const parser::Selector &);
+ SemanticsContext &context_;
+};
+} // namespace Fortran::semantics
+#endif // FORTRAN_SEMANTICS_CHECK_SELECT_TYPE_H_
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 218dcc07b270..4e159b5d2f77 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -5147,6 +5147,12 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
// This isn't a name in the current scope, it is in each TypeGuardStmt
MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName);
association.name = &*name;
+ auto exprType{association.selector.expr->GetType()};
+ if (exprType && !exprType->IsPolymorphic()) { // C1159
+ Say(association.selector.source,
+ "Selector '%s' in SELECT TYPE statement must be "
+ "polymorphic"_err_en_US);
+ }
} else {
if (const Symbol *
whole{UnwrapWholeSymbolDataRef(association.selector.expr)}) {
@@ -5156,6 +5162,13 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
"Selector is not a variable"_err_en_US);
association = {};
}
+ if (const DeclTypeSpec * type{whole->GetType()}) {
+ if (!type->IsPolymorphic()) { // C1159
+ Say(association.selector.source,
+ "Selector '%s' in SELECT TYPE statement must be "
+ "polymorphic"_err_en_US);
+ }
+ }
} else {
Say(association.selector.source, // C1157
"Selector is not a named variable: 'associate-name =>' is required"_err_en_US);
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 4eacb9972ebe..b8327213682b 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -26,6 +26,7 @@
#include "check-purity.h"
#include "check-return.h"
#include "check-select-rank.h"
+#include "check-select-type.h"
#include "check-stop.h"
#include "compute-offsets.h"
#include "mod-file.h"
@@ -157,7 +158,8 @@ using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker,
DataChecker, DeallocateChecker, DoForallChecker, IfStmtChecker, IoChecker,
MiscChecker, NamelistChecker, NullifyChecker, OmpStructureChecker,
- PurityChecker, ReturnStmtChecker, SelectRankConstructChecker, StopChecker>;
+ PurityChecker, ReturnStmtChecker, SelectRankConstructChecker,
+ SelectTypeChecker, StopChecker>;
static bool PerformStatementSemantics(
SemanticsContext &context, parser::Program &program) {
diff --git a/flang/test/Semantics/selecttype01.f90 b/flang/test/Semantics/selecttype01.f90
new file mode 100644
index 000000000000..fe9838ae2760
--- /dev/null
+++ b/flang/test/Semantics/selecttype01.f90
@@ -0,0 +1,241 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Test for checking select type constraints,
+module m1
+ use ISO_C_BINDING
+ type shape
+ integer :: color
+ logical :: filled
+ integer :: x
+ integer :: y
+ end type shape
+
+ type, extends(shape) :: rectangle
+ integer :: length
+ integer :: width
+ end type rectangle
+
+ type, extends(rectangle) :: square
+ end type square
+
+ type, extends(square) :: extsquare
+ end type
+
+ type :: unrelated
+ logical :: some_logical
+ end type
+
+ type withSequence
+ SEQUENCE
+ integer :: x
+ end type
+
+ type, BIND(C) :: withBind
+ INTEGER(c_int) ::int_in_c
+ end type
+
+ TYPE(shape), TARGET :: shape_obj
+ TYPE(rectangle), TARGET :: rect_obj
+ TYPE(square), TARGET :: squr_obj
+ !define polymorphic objects
+ class(*), pointer :: unlim_polymorphic
+ class(shape), pointer :: shape_lim_polymorphic
+end
+module m
+ type :: t(n)
+ integer, len :: n
+ end type
+contains
+ subroutine CheckC1160( a )
+ class(*), intent(in) :: a
+ select type ( a )
+ !ERROR: The type specification statement must have LEN type parameter as assumed
+ type is ( character(len=10) ) !<-- assumed length-type
+ ! OK
+ type is ( character(len=*) )
+ !ERROR: The type specification statement must have LEN type parameter as assumed
+ type is ( t(n=10) )
+ ! OK
+ type is ( t(n=*) ) !<-- assumed length-type
+ !ERROR: Derived type 'character' not found
+ class is ( character(len=10) ) !<-- assumed length-type
+ end select
+ end subroutine
+
+ subroutine s()
+ type derived(param)
+ integer, len :: param
+ class(*), allocatable :: x
+ end type
+ TYPE(derived(10)) :: a
+ select type (ax => a%x)
+ class is (derived(param=*))
+ print *, "hello"
+ end select
+ end subroutine s
+end module
+
+subroutine CheckC1157
+ use m1
+ integer, parameter :: const_var=10
+ !ERROR: Selector is not a named variable: 'associate-name =>' is required
+ select type(10)
+ end select
+ !ERROR: Selector is not a named variable: 'associate-name =>' is required
+ select type(const_var)
+ end select
+ !ERROR: Selector is not a named variable: 'associate-name =>' is required
+ select type (4.999)
+ end select
+ !ERROR: Selector is not a named variable: 'associate-name =>' is required
+ select type (shape_obj%x)
+ end select
+end subroutine
+
+!CheckPloymorphicSelectorType
+subroutine CheckC1159a
+ integer :: int_variable
+ real :: real_variable
+ complex :: complex_var = cmplx(3.0, 4.0)
+ logical :: log_variable
+ character (len=10) :: char_variable = "OM"
+ !ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic
+ select type (int_variable)
+ end select
+ !ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic
+ select type (real_variable)
+ end select
+ !ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic
+ select type(complex_var)
+ end select
+ !ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic
+ select type(logical_variable)
+ end select
+ !ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic
+ select type(char_variable)
+ end select
+end
+
+subroutine CheckC1159b
+ integer :: x
+ !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
+ select type (a => x)
+ type is (integer)
+ print *,'integer ',a
+ end select
+end
+
+subroutine CheckC1159c
+ !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
+ select type (a => x)
+ type is (integer)
+ print *,'integer ',a
+ end select
+end
+
+subroutine s(arg)
+ class(*) :: arg
+ select type (arg)
+ type is (integer)
+ end select
+end
+
+subroutine CheckC1161
+ use m1
+ shape_lim_polymorphic => rect_obj
+ select type(shape_lim_polymorphic)
+ !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+ type is (withSequence)
+ !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+ type is (withBind)
+ end select
+end
+
+subroutine CheckC1162
+ use m1
+ class(rectangle), pointer :: rectangle_polymorphic
+ !not unlimited polymorphic objects
+ select type (rectangle_polymorphic)
+ !ERROR: Type specification 'shape' must be an extension of TYPE 'rectangle'
+ type is (shape)
+ !ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
+ type is (unrelated)
+ !all are ok
+ type is (square)
+ type is (extsquare)
+ !Handle same types
+ type is (rectangle)
+ end select
+
+ !Unlimited polymorphic objects are allowed.
+ unlim_polymorphic => rect_obj
+ select type (unlim_polymorphic)
+ type is (shape)
+ type is (unrelated)
+ end select
+end
+
+subroutine CheckC1163
+ use m1
+ !assign dynamically
+ shape_lim_polymorphic => rect_obj
+ unlim_polymorphic => shape_obj
+ select type (shape_lim_polymorphic)
+ type is (shape)
+ !ERROR: Type specification 'shape' conflicts with previous type specification
+ type is (shape)
+ class is (square)
+ !ERROR: Type specification 'square' conflicts with previous type specification
+ class is (square)
+ end select
+end
+
+subroutine CheckC1164
+ use m1
+ shape_lim_polymorphic => rect_obj
+ unlim_polymorphic => shape_obj
+ select type (shape_lim_polymorphic)
+ CLASS DEFAULT
+ !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
+ CLASS DEFAULT
+ TYPE IS (shape)
+ TYPE IS (rectangle)
+ !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
+ CLASS DEFAULT
+ end select
+
+ !Saving computation if some error in guard by not computing RepeatingCases
+ select type (shape_lim_polymorphic)
+ CLASS DEFAULT
+ CLASS DEFAULT
+ !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
+ TYPE IS(withSequence)
+ end select
+end subroutine
+
+subroutine WorkingPolymorphism
+ use m1
+ !assign dynamically
+ shape_lim_polymorphic => rect_obj
+ unlim_polymorphic => shape_obj
+ select type (shape_lim_polymorphic)
+ type is (shape)
+ print *, "hello shape"
+ type is (rectangle)
+ print *, "hello rect"
+ type is (square)
+ print *, "hello square"
+ CLASS DEFAULT
+ print *, "default"
+ end select
+ print *, "unlim polymorphism"
+ select type (unlim_polymorphic)
+ type is (shape)
+ print *, "hello shape"
+ type is (rectangle)
+ print *, "hello rect"
+ type is (square)
+ print *, "hello square"
+ CLASS DEFAULT
+ print *, "default"
+ end select
+end
diff --git a/flang/test/Semantics/selecttype02.f90 b/flang/test/Semantics/selecttype02.f90
new file mode 100644
index 000000000000..3f4226ec7c03
--- /dev/null
+++ b/flang/test/Semantics/selecttype02.f90
@@ -0,0 +1,51 @@
+! RUN: %S/test_errors.sh %s %t %f18
+module m1
+ use ISO_C_BINDING
+ type shape
+ integer :: color
+ logical :: filled
+ integer :: x
+ integer :: y
+ end type shape
+ type, extends(shape) :: rectangle
+ integer :: length
+ integer :: width
+ end type rectangle
+ type, extends(rectangle) :: square
+ end type square
+
+ TYPE(shape), TARGET :: shape_obj
+ TYPE(rectangle), TARGET :: rect_obj
+ !define polymorphic objects
+ class(shape), pointer :: shape_lim_polymorphic
+end
+subroutine C1165a
+ use m1
+ shape_lim_polymorphic => rect_obj
+ label : select type (shape_lim_polymorphic)
+ end select label
+ label1 : select type (shape_lim_polymorphic)
+ !ERROR: SELECT TYPE construct name required but missing
+ end select
+ select type (shape_lim_polymorphic)
+ !ERROR: SELECT TYPE construct name unexpected
+ end select label2
+ select type (shape_lim_polymorphic)
+ end select
+end subroutine
+subroutine C1165b
+ use m1
+ shape_lim_polymorphic => rect_obj
+!type-guard-stmt realted checks
+label : select type (shape_lim_polymorphic)
+ type is (shape) label
+ end select label
+ select type (shape_lim_polymorphic)
+ !ERROR: SELECT TYPE name not allowed
+ type is (shape) label
+ end select
+label : select type (shape_lim_polymorphic)
+ !ERROR: SELECT TYPE name mismatch
+ type is (shape) labelll
+ end select label
+end subroutine
diff --git a/flang/test/Semantics/selecttype03.f90 b/flang/test/Semantics/selecttype03.f90
new file mode 100644
index 000000000000..e989eb15fe33
--- /dev/null
+++ b/flang/test/Semantics/selecttype03.f90
@@ -0,0 +1,123 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Test various conditions in C1158.
+implicit none
+
+type :: t1
+ integer :: i
+end type
+
+type, extends(t1) :: t2
+end type
+
+type(t1),target :: x1
+type(t2),target :: x2
+
+class(*), pointer :: ptr
+class(t1), pointer :: p_or_c
+!vector subscript related
+class(t1),DIMENSION(:,:),allocatable::array1
+class(t2),DIMENSION(:,:),allocatable::array2
+integer, dimension(2) :: V
+V = (/ 1,2 /)
+allocate(array1(3,3))
+allocate(array2(3,3))
+
+! A) associate with function, i.e (other than variables)
+select type ( y => fun(1) )
+ type is (t1)
+ print *, rank(y%i)
+end select
+
+select type ( y => fun(1) )
+ type is (t1)
+ !ERROR: Left-hand side of assignment is not modifiable
+ y%i = 1 !VDC
+ type is (t2)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+ call sub_with_in_and_inout_param(y,y) !VDC
+end select
+
+! B) associated with a variable:
+p_or_c => x1
+select type ( a => p_or_c )
+ type is (t1)
+ a%i = 10
+end select
+
+select type ( a => p_or_c )
+ type is (t1)
+end select
+
+!C)Associate with with vector subscript
+select type (b => array1(V,2))
+ type is (t1)
+ !ERROR: Left-hand side of assignment is not modifiable
+ b%i = 1 !VDC
+ type is (t2)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+ call sub_with_in_and_inout_param_vector(b,b) !VDC
+end select
+select type(b => foo(1) )
+ type is (t1)
+ !ERROR: Left-hand side of assignment is not modifiable
+ b%i = 1 !VDC
+ type is (t2)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
+ call sub_with_in_and_inout_param_vector(b,b) !VDC
+end select
+
+!D) Have no association and should be ok.
+!1. points to function
+ptr => fun(1)
+select type ( ptr )
+type is (t1)
+ ptr%i = 1
+end select
+
+!2. points to variable
+ptr=>x1
+select type (ptr)
+ type is (t1)
+ ptr%i = 10
+end select
+
+contains
+
+ function fun(i)
+ class(t1),pointer :: fun
+ integer :: i
+ if (i>0) then
+ fun => x1
+ else if (i<0) then
+ fun => x2
+ else
+ fun => NULL()
+ end if
+ end function
+
+ function foo(i)
+ integer :: i
+ class(t1),DIMENSION(:),allocatable :: foo
+ integer, dimension(2) :: U
+ U = (/ 1,2 /)
+ if (i>0) then
+ foo = array1(2,U)
+ else if (i<0) then
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t2)
+ foo = array2(2,U)
+ end if
+ end function
+
+ subroutine sub_with_in_and_inout_param(y, z)
+ type(t2), INTENT(IN) :: y
+ class(t2), INTENT(INOUT) :: z
+ z%i = 10
+ end subroutine
+
+ subroutine sub_with_in_and_inout_param_vector(y, z)
+ type(t2),DIMENSION(:), INTENT(IN) :: y
+ class(t2),DIMENSION(:), INTENT(INOUT) :: z
+ z%i = 10
+ end subroutine
+
+end
More information about the flang-commits
mailing list