Index: flang/include/flang/Semantics/semantics.h =================================================================== --- flang/include/flang/Semantics/semantics.h +++ flang/include/flang/Semantics/semantics.h @@ -168,10 +168,12 @@ return messages_.Say(std::move(msg)); } template - void SayWithDecl(const Symbol &symbol, const parser::CharBlock &at, - parser::MessageFixedText &&msg, A &&...args) { + parser::Message &SayWithDecl(const Symbol &symbol, + const parser::CharBlock &at, parser::MessageFixedText &&msg, + A &&...args) { auto &message{Say(at, std::move(msg), args...)}; evaluate::AttachDeclaration(&message, symbol); + return message; } const Scope &FindScope(parser::CharBlock) const; Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -609,11 +609,6 @@ // procedure. bool HasDefinedIo( GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr); -// Seeks out an allocatable or pointer ultimate component that is not -// nested in a nonallocatable/nonpointer component with a specific -// defined I/O procedure. -const Symbol *FindUnsafeIoDirectComponent( - GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr); // Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and // `operator(==)`). GetAllNames() returns them all, including symbolName. Index: flang/lib/Semantics/check-io.h =================================================================== --- flang/lib/Semantics/check-io.h +++ flang/lib/Semantics/check-io.h @@ -126,8 +126,15 @@ void CheckForPureSubprogram() const; - void CheckForBadIoComponent( + parser::Message *CheckForBadIoType(const evaluate::DynamicType &, + GenericKind::DefinedIo, parser::CharBlock) const; + void CheckForBadIoType( const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const; + parser::Message *CheckForBadIoType( + const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const; + + void CheckNamelist( + const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const; void Init(IoStmtKind s) { stmt_ = s; Index: flang/lib/Semantics/check-io.cpp =================================================================== --- flang/lib/Semantics/check-io.cpp +++ flang/lib/Semantics/check-io.cpp @@ -323,7 +323,7 @@ } CheckForDefinableVariable(*var, "Input"); if (auto expr{AnalyzeExpr(context_, *var)}) { - CheckForBadIoComponent(*expr, + CheckForBadIoType(*expr, flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted : GenericKind::DefinedIo::ReadUnformatted, var->GetSource()); @@ -616,7 +616,7 @@ context_.Say(parser::FindSourceLocation(*x), "Output item must not be a procedure pointer"_err_en_US); // C1233 } - CheckForBadIoComponent(*expr, + CheckForBadIoType(*expr, flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::WriteFormatted : GenericKind::DefinedIo::WriteUnformatted, @@ -738,29 +738,21 @@ Done(); } -static void CheckForDoVariableInNamelist(const Symbol &namelist, - SemanticsContext &context, parser::CharBlock namelistLocation) { - const auto &details{namelist.GetUltimate().get()}; - for (const Symbol &object : details.objects()) { - context.CheckIndexVarRedefine(namelistLocation, object); - } -} - -static void CheckForDoVariableInNamelistSpec( - const parser::ReadStmt &readStmt, SemanticsContext &context) { - const std::list &controls{readStmt.controls}; +static const parser::Name *FindNamelist( + const std::list &controls) { for (const auto &control : controls) { - if (const auto *namelist{std::get_if(&control.u)}) { - if (const Symbol * symbol{namelist->symbol}) { - CheckForDoVariableInNamelist(*symbol, context, namelist->source); + if (const parser::Name * namelist{std::get_if(&control.u)}) { + if (namelist->symbol && + namelist->symbol->GetUltimate().has()) { + return namelist; } } } + return nullptr; } static void CheckForDoVariable( const parser::ReadStmt &readStmt, SemanticsContext &context) { - CheckForDoVariableInNamelistSpec(readStmt, context); const std::list &items{readStmt.items}; for (const auto &item : items) { if (const parser::Variable * @@ -774,6 +766,12 @@ if (!flags_.test(Flag::InternalUnit)) { CheckForPureSubprogram(); } + if (const parser::Name * namelist{FindNamelist(readStmt.controls)}) { + if (namelist->symbol) { + CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::ReadFormatted, + namelist->source); + } + } CheckForDoVariable(readStmt, context_); if (!flags_.test(Flag::IoControlList)) { Done(); @@ -807,10 +805,16 @@ Done(); } -void IoChecker::Leave(const parser::WriteStmt &) { +void IoChecker::Leave(const parser::WriteStmt &writeStmt) { if (!flags_.test(Flag::InternalUnit)) { CheckForPureSubprogram(); } + if (const parser::Name * namelist{FindNamelist(writeStmt.controls)}) { + if (namelist->symbol) { + CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::WriteFormatted, + namelist->source); + } + } LeaveReadWrite(); CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213 CheckForProhibitedSpecifier(IoSpecKind::End); // C1213 @@ -1030,20 +1034,139 @@ } } -// Fortran 2018, 12.6.3 paragraph 7 -void IoChecker::CheckForBadIoComponent(const SomeExpr &expr, +// Seeks out an allocatable or pointer ultimate component that is not +// nested in a nonallocatable/nonpointer component with a specific +// defined I/O procedure. +static const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which, + const DerivedTypeSpec &derived, const Scope &scope) { + if (HasDefinedIo(which, derived, &scope)) { + return nullptr; + } + if (const Scope * dtScope{derived.scope()}) { + for (const auto &pair : *dtScope) { + const Symbol &symbol{*pair.second}; + if (IsAllocatableOrPointer(symbol)) { + return &symbol; + } + if (const auto *details{symbol.detailsIf()}) { + if (const DeclTypeSpec * type{details->type()}) { + if (type->category() == DeclTypeSpec::Category::TypeDerived) { + const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()}; + if (const Symbol * + bad{FindUnsafeIoDirectComponent( + which, componentDerived, scope)}) { + return bad; + } + } + } + } + } + } + return nullptr; +} + +// For a type that does not have a defined I/O subroutine, finds a direct +// component that is a witness to an accessibility violation outside the module +// in which the type was defined. +static const Symbol *FindInaccessibleComponent(GenericKind::DefinedIo which, + const DerivedTypeSpec &derived, const Scope &scope) { + if (const Scope * dtScope{derived.scope()}) { + if (const Scope * module{FindModuleContaining(*dtScope)}) { + for (const auto &pair : *dtScope) { + const Symbol &symbol{*pair.second}; + if (IsAllocatableOrPointer(symbol)) { + continue; // already an error + } + if (const auto *details{symbol.detailsIf()}) { + const DerivedTypeSpec *componentDerived{nullptr}; + if (const DeclTypeSpec * type{details->type()}) { + if (type->category() == DeclTypeSpec::Category::TypeDerived) { + componentDerived = &type->derivedTypeSpec(); + } + } + if (componentDerived && + HasDefinedIo(which, *componentDerived, &scope)) { + continue; // this component and its descendents are fine + } + if (symbol.attrs().test(Attr::PRIVATE) && + !symbol.test(Symbol::Flag::ParentComp)) { + if (!DoesScopeContain(module, scope)) { + return &symbol; + } + } + if (componentDerived) { + if (const Symbol * + bad{FindInaccessibleComponent( + which, *componentDerived, scope)}) { + return bad; + } + } + } + } + } + } + return nullptr; +} + +// Fortran 2018, 12.6.3 paragraphs 5 & 7 +parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type, GenericKind::DefinedIo which, parser::CharBlock where) const { - if (auto type{expr.GetType()}) { - if (type->category() == TypeCategory::Derived && - !type->IsUnlimitedPolymorphic()) { + if (type.IsUnlimitedPolymorphic()) { + return &context_.Say( + where, "I/O list item may not be unlimited polymorphic"_err_en_US); + } else if (type.category() == TypeCategory::Derived) { + const auto &derived{type.GetDerivedTypeSpec()}; + const Scope &scope{context_.FindScope(where)}; + if (const Symbol * + bad{FindUnsafeIoDirectComponent(which, derived, scope)}) { + return &context_.SayWithDecl(*bad, where, + "Derived type '%s' in I/O cannot have an allocatable or pointer direct component '%s' unless using defined I/O"_err_en_US, + derived.name(), bad->name()); + } + if (!HasDefinedIo(which, derived, &scope)) { + if (type.IsPolymorphic()) { + return &context_.Say(where, + "Derived type '%s' in I/O may not be polymorphic unless using defined I/O"_err_en_US, + derived.name()); + } if (const Symbol * - bad{FindUnsafeIoDirectComponent( - which, type->GetDerivedTypeSpec(), &context_.FindScope(where))}) { - context_.SayWithDecl(*bad, where, - "Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O"_err_en_US); + bad{FindInaccessibleComponent(which, derived, scope)}) { + return &context_.Say(where, + "I/O of the derived type '%s' may not be performed without defined I/O in a scope in which a direct component like '%s' is inaccessible"_err_en_US, + derived.name(), bad->name()); } } } + return nullptr; +} + +void IoChecker::CheckForBadIoType(const SomeExpr &expr, + GenericKind::DefinedIo which, parser::CharBlock where) const { + if (auto type{expr.GetType()}) { + CheckForBadIoType(*type, which, where); + } +} + +parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol, + GenericKind::DefinedIo which, parser::CharBlock where) const { + if (auto type{evaluate::DynamicType::From(symbol)}) { + if (auto *msg{CheckForBadIoType(*type, which, where)}) { + evaluate::AttachDeclaration(*msg, symbol); + return msg; + } + } + return nullptr; +} + +void IoChecker::CheckNamelist(const Symbol &namelist, + GenericKind::DefinedIo which, parser::CharBlock namelistLocation) const { + const auto &details{namelist.GetUltimate().get()}; + for (const Symbol &object : details.objects()) { + context_.CheckIndexVarRedefine(namelistLocation, object); + if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) { + evaluate::AttachDeclaration(*msg, namelist); + } + } } } // namespace Fortran::semantics Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -1194,6 +1194,7 @@ // Creates Block scopes with neither symbol name nor symbol details. bool Pre(const parser::SelectRankConstruct::RankCase &); void Post(const parser::SelectRankConstruct::RankCase &); + bool Pre(const parser::TypeGuardStmt::Guard &); void Post(const parser::TypeGuardStmt::Guard &); void Post(const parser::SelectRankCaseStmt::Rank &); bool Pre(const parser::ChangeTeamStmt &); @@ -6398,6 +6399,14 @@ PopScope(); } +bool ConstructVisitor::Pre(const parser::TypeGuardStmt::Guard &x) { + if (std::holds_alternative(x.u)) { + // CLASS IS (t) + SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived); + } + return true; +} + void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { if (auto *symbol{MakeAssocEntity()}) { if (std::holds_alternative(x.u)) { Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -1484,31 +1484,4 @@ return false; } -const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which, - const DerivedTypeSpec &derived, const Scope *scope) { - if (HasDefinedIo(which, derived, scope)) { - return nullptr; - } - if (const Scope * dtScope{derived.scope()}) { - for (const auto &pair : *dtScope) { - const Symbol &symbol{*pair.second}; - if (IsAllocatableOrPointer(symbol)) { - return &symbol; - } - if (const auto *details{symbol.detailsIf()}) { - if (const DeclTypeSpec * type{details->type()}) { - if (type->category() == DeclTypeSpec::Category::TypeDerived) { - if (const Symbol * - bad{FindUnsafeIoDirectComponent( - which, type->derivedTypeSpec(), scope)}) { - return bad; - } - } - } - } - } - } - return nullptr; -} - } // namespace Fortran::semantics Index: flang/test/Semantics/io12.f90 =================================================================== --- flang/test/Semantics/io12.f90 +++ flang/test/Semantics/io12.f90 @@ -52,9 +52,9 @@ type(maybeBad) :: y type(poison) :: z write(u) x ! always ok - !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O + !ERROR: Derived type 'maybebad' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O write(u) y ! bad here - !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O + !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O write(u) z ! bad end subroutine end module @@ -69,7 +69,7 @@ type(poison) :: z write(u) x ! always ok write(u) y ! ok here - !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O + !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O write(u) z ! bad end subroutine end module Index: flang/test/Semantics/io14.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/io14.f90 @@ -0,0 +1,37 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Test polymorphic restrictions +module m + type base + end type + type, extends(base) :: t + integer n + contains + procedure :: fwrite + generic :: write(formatted) => fwrite + end type + contains + subroutine fwrite(x, unit, iotype, vlist, iostat, iomsg) + class(t), intent(in) :: x + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character(*), intent(in out) :: iomsg + write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%n, ')' + end subroutine + subroutine subr(x, y, z) + class(t), intent(in) :: x + class(base), intent(in) :: y + class(*), intent(in) :: z + print *, x ! ok + !ERROR: Derived type 'base' in I/O may not be polymorphic unless using defined I/O + print *, y + !ERROR: I/O list item may not be unlimited polymorphic + print *, z + end subroutine +end + +program main + use m + call subr(t(123),t(234),t(345)) +end Index: flang/test/Semantics/io15.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/io15.f90 @@ -0,0 +1,55 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Test visibility restrictions +module m + type t1 + integer, private :: ip1 = 123 + contains + procedure :: fwrite1 + generic :: write(formatted) => fwrite1 + end type t1 + type t2 + integer, private :: ip2 = 234 + type(t1) x1 + end type t2 + type t3 + type(t1) x1 + type(t2) x2 + end type t3 + type, extends(t2) :: t4 + end type t4 + contains + subroutine fwrite1(x, unit, iotype, vlist, iostat, iomsg) + class(t1), intent(in) :: x + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character(*), intent(in out) :: iomsg + write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%ip1, ')' + end subroutine + subroutine local ! all OK since type is local + type(t1) :: x1 + type(t2) :: x2 + type(t3) :: x3 + type(t4) :: x4 + print *, x1 + print *, x2 + print *, x3 + print *, x4 + end subroutine +end module + +program main + use m + type(t1) :: x1 + type(t2) :: x2 + type(t3) :: x3 + type(t4) :: x4 + print *, x1 ! ok + !ERROR: I/O of the derived type 't2' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible + print *, x2 + !ERROR: I/O of the derived type 't3' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible + print *, x3 + !ERROR: I/O of the derived type 't4' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible + print *, x4 +end Index: flang/test/Semantics/symbol11.f90 =================================================================== --- flang/test/Semantics/symbol11.f90 +++ flang/test/Semantics/symbol11.f90 @@ -68,7 +68,7 @@ !REF: /s3/t2 class is (t2) !REF: /s3/i - !DEF: /s3/OtherConstruct1/y TARGET AssocEntity TYPE(t2) + !DEF: /s3/OtherConstruct1/y TARGET AssocEntity CLASS(t2) !REF: /s3/t2/a2 i = y%a2 !REF: /s3/t1 @@ -79,7 +79,8 @@ i = y%a1 class default !DEF: /s3/OtherConstruct3/y TARGET AssocEntity CLASS(t1) - print *, y + !REF:/s3/t1/a1 + print *, y%a1 end select end subroutine