From 5ea0ba2c13af3c6c8e68701b00695f0f0481bed0 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Wed, 30 Nov 2022 15:20:49 -0800 Subject: [PATCH] [flang] Enforce more restrictions on I/O data list items 12.6.3p5 requires an I/O data list item to have a defined I/O procedure if it is polymorphic. (We could defer this checking to the runtime, but no other Fortran compiler does so, and we would also have to be able to catch the case of an allocatable or pointer direct component in the absence of a defined I/O subroutine.) Also includes a patch to name resolution that ensures that a SELECT TYPE construct entity is polymorphic in the domain of a CLASS IS guard. Also ensures that non-defined I/O of types with PRIVATE components is caught. Differential Revision: https://reviews.llvm.org/D139050 --- flang/include/flang/Semantics/semantics.h | 6 +- flang/include/flang/Semantics/tools.h | 5 - flang/lib/Semantics/check-io.cpp | 177 +++++++++++++++++++++++++----- flang/lib/Semantics/check-io.h | 9 +- flang/lib/Semantics/resolve-names.cpp | 9 ++ flang/lib/Semantics/tools.cpp | 27 ----- flang/test/Semantics/io12.f90 | 6 +- flang/test/Semantics/io14.f90 | 37 +++++++ flang/test/Semantics/io15.f90 | 55 ++++++++++ flang/test/Semantics/symbol11.f90 | 5 +- 10 files changed, 269 insertions(+), 67 deletions(-) create mode 100644 flang/test/Semantics/io14.f90 create mode 100644 flang/test/Semantics/io15.f90 diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h index 2d08a9f..04a1d6b 100644 --- a/flang/include/flang/Semantics/semantics.h +++ b/flang/include/flang/Semantics/semantics.h @@ -168,10 +168,12 @@ public: 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; diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 7b2c4bf..88cb720 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -610,11 +610,6 @@ std::optional ToArraySpec( // 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. diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp index 5e25e51..ee7eb02 100644 --- a/flang/lib/Semantics/check-io.cpp +++ b/flang/lib/Semantics/check-io.cpp @@ -323,7 +323,7 @@ void IoChecker::Enter(const parser::InputItem &spec) { } 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 @@ void IoChecker::Enter(const parser::OutputItem &item) { 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 @@ void IoChecker::Leave(const parser::PrintStmt &) { 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 @@ void IoChecker::Leave(const parser::ReadStmt &readStmt) { 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 @@ void IoChecker::Leave(const parser::WaitStmt &) { 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 @@ void IoChecker::CheckForPureSubprogram() const { // C1597 } } -// 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 diff --git a/flang/lib/Semantics/check-io.h b/flang/lib/Semantics/check-io.h index c23652a..03738e8 100644 --- a/flang/lib/Semantics/check-io.h +++ b/flang/lib/Semantics/check-io.h @@ -126,8 +126,15 @@ private: 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; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index e53d340..510f7cb 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1194,6 +1194,7 @@ public: // 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 &); @@ -6407,6 +6408,14 @@ void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) { 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)) { diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index dbe50df..5ac5f9d 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1514,31 +1514,4 @@ bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived, 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 diff --git a/flang/test/Semantics/io12.f90 b/flang/test/Semantics/io12.f90 index f0f2ae1..474b07c 100644 --- a/flang/test/Semantics/io12.f90 +++ b/flang/test/Semantics/io12.f90 @@ -52,9 +52,9 @@ module m3 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 @@ module m4 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 diff --git a/flang/test/Semantics/io14.f90 b/flang/test/Semantics/io14.f90 new file mode 100644 index 0000000..6dd6763 --- /dev/null +++ b/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 diff --git a/flang/test/Semantics/io15.f90 b/flang/test/Semantics/io15.f90 new file mode 100644 index 0000000..a00732a --- /dev/null +++ b/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 diff --git a/flang/test/Semantics/symbol11.f90 b/flang/test/Semantics/symbol11.f90 index 1fbe685..3702936 100644 --- a/flang/test/Semantics/symbol11.f90 +++ b/flang/test/Semantics/symbol11.f90 @@ -68,7 +68,7 @@ subroutine s3 !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 @@ subroutine s3 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 -- 2.7.4