From: sameeran joshi Date: Sun, 19 Apr 2020 11:10:37 +0000 (+0530) Subject: [flang] Semantics for SELECT TYPE X-Git-Tag: llvmorg-12-init~3348 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=70ad73b6b76838bd7c72123922102b175e5d478a;p=platform%2Fupstream%2Fllvm.git [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 --- diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt index ff2eba6..4fd75bc 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 657e618..ab8f5e4 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 1639445..282a877 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 0000000..5b43044 --- /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 + +namespace Fortran::semantics { + +class TypeCaseValues { +public: + TypeCaseValues(SemanticsContext &c, const evaluate::DynamicType &t) + : context_{c}, selectorType_{t} {} + void Check(const std::list &cases) { + for (const auto &c : cases) { + AddTypeCase(c); + } + if (!hasErrors_) { + ReportConflictingTypeCases(); + } + } + +private: + void AddTypeCase(const parser::SelectTypeConstruct::TypeCase &c) { + const auto &stmt{std::get>(c.t)}; + const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; + const auto &guard{std::get(typeGuardStmt.t)}; + if (std::holds_alternative(guard.u)) { + typeCases_.emplace_back(stmt, std::nullopt); + } else if (std::optional type{GetGuardType(guard)}) { + if (PassesChecksOnGuard(guard, *type)) { + typeCases_.emplace_back(stmt, *type); + } else { + hasErrors_ = true; + } + } else { + hasErrors_ = true; + } + } + + std::optional GetGuardType( + const parser::TypeGuardStmt::Guard &guard) { + return std::visit( + common::visitors{ + [](const parser::Default &) + -> std::optional { + return std::nullopt; + }, + [](const parser::TypeSpec &typeSpec) { + return evaluate::DynamicType::From(typeSpec.declTypeSpec); + }, + [](const parser::DerivedTypeSpec &spec) + -> std::optional { + 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 &s, + std::optional guardTypeDynamic) + : stmt{s} { + SetGuardType(guardTypeDynamic); + } + + void SetGuardType(std::optional 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(guard.u); + } + + bool IsTypeSpec() const { + const auto &guard{GetGuardFromStmt(stmt)}; + return std::holds_alternative(guard.u); + } + + bool IsDerivedTypeSpec() const { + const auto &guard{GetGuardFromStmt(stmt)}; + return std::holds_alternative(guard.u); + } + + const parser::TypeGuardStmt::Guard &GetGuardFromStmt( + const parser::Statement &stmt) const { + const parser::TypeGuardStmt &typeGuardStmt{stmt.statement}; + return std::get(typeGuardStmt.t); + } + + std::optional 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 &stmt; + std::optional 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 typeCases_; + bool hasErrors_{false}; +}; + +void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) { + const auto &selectTypeStmt{ + std::get>(construct.t)}; + const auto &selectType{selectTypeStmt.statement}; + const auto &unResolvedSel{std::get(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>( + 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 0000000..87b58e7 --- /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 218dcc0..4e159b5 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 4eacb99..b832721 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; + 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 0000000..fe9838a --- /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 0000000..3f4226ec --- /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 0000000..e989eb1 --- /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