Index: flang/include/flang/Semantics/symbol.h =================================================================== --- flang/include/flang/Semantics/symbol.h +++ flang/include/flang/Semantics/symbol.h @@ -423,6 +423,7 @@ bool IsIntrinsicOperator() const; bool IsOperator() const; std::string ToString() const; + static SourceName AsFortran(DefinedIo); std::variant u; Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -528,6 +528,8 @@ const DerivedTypeSpec &); UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent( const DerivedTypeSpec &); +DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent( + const DerivedTypeSpec &); UltimateComponentIterator::const_iterator FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &); UltimateComponentIterator::const_iterator @@ -583,5 +585,15 @@ std::optional ToArraySpec( evaluate::FoldingContext &, const std::optional &); +// Searches a derived type and a scope for a particular user defined I/O +// 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); + } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_TOOLS_H_ Index: flang/lib/Semantics/check-io.h =================================================================== --- flang/lib/Semantics/check-io.h +++ flang/lib/Semantics/check-io.h @@ -126,6 +126,9 @@ void CheckForPureSubprogram() const; + void CheckForBadIoComponent( + const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const; + void Init(IoStmtKind s) { stmt_ = s; specifierSet_.reset(); Index: flang/lib/Semantics/check-io.cpp =================================================================== --- flang/lib/Semantics/check-io.cpp +++ flang/lib/Semantics/check-io.cpp @@ -319,6 +319,12 @@ return; } CheckForDefinableVariable(*var, "Input"); + if (auto expr{AnalyzeExpr(context_, *var)}) { + CheckForBadIoComponent(*expr, + flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted + : GenericKind::DefinedIo::ReadUnformatted, + var->GetSource()); + } } void IoChecker::Enter(const parser::InquireSpec &spec) { @@ -580,6 +586,11 @@ context_.Say(parser::FindSourceLocation(*x), "Output item must not be a procedure pointer"_err_en_US); // C1233 } + CheckForBadIoComponent(*expr, + flags_.test(Flag::FmtOrNml) + ? GenericKind::DefinedIo::WriteFormatted + : GenericKind::DefinedIo::WriteUnformatted, + parser::FindSourceLocation(item)); } } } @@ -987,4 +998,20 @@ } } +// Fortran 2018, 12.6.3 paragraph 7 +void IoChecker::CheckForBadIoComponent(const SomeExpr &expr, + GenericKind::DefinedIo which, parser::CharBlock where) const { + if (auto type{expr.GetType()}) { + if (type->category() == TypeCategory::Derived && + !type->IsUnlimitedPolymorphic()) { + 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); + } + } + } +} + } // namespace Fortran::semantics Index: flang/lib/Semantics/runtime-type-info.cpp =================================================================== --- flang/lib/Semantics/runtime-type-info.cpp +++ flang/lib/Semantics/runtime-type-info.cpp @@ -74,8 +74,8 @@ const Symbol &specificOrBinding, bool isAssignment, bool isFinal, std::optional); void IncorporateDefinedIoGenericInterfaces( - std::map &, SourceName, - GenericKind::DefinedIo, const Scope *); + std::map &, GenericKind::DefinedIo, + const Scope *); // Instantiated for ParamValue and Bound template @@ -523,18 +523,14 @@ DescribeSpecialProc( specials, *pair.second, false /*!isAssignment*/, true, std::nullopt); } - IncorporateDefinedIoGenericInterfaces(specials, - SourceName{"read(formatted)", 15}, - GenericKind::DefinedIo::ReadFormatted, &scope); - IncorporateDefinedIoGenericInterfaces(specials, - SourceName{"read(unformatted)", 17}, - GenericKind::DefinedIo::ReadUnformatted, &scope); - IncorporateDefinedIoGenericInterfaces(specials, - SourceName{"write(formatted)", 16}, - GenericKind::DefinedIo::WriteFormatted, &scope); - IncorporateDefinedIoGenericInterfaces(specials, - SourceName{"write(unformatted)", 18}, - GenericKind::DefinedIo::WriteUnformatted, &scope); + IncorporateDefinedIoGenericInterfaces( + specials, GenericKind::DefinedIo::ReadFormatted, &scope); + IncorporateDefinedIoGenericInterfaces( + specials, GenericKind::DefinedIo::ReadUnformatted, &scope); + IncorporateDefinedIoGenericInterfaces( + specials, GenericKind::DefinedIo::WriteFormatted, &scope); + IncorporateDefinedIoGenericInterfaces( + specials, GenericKind::DefinedIo::WriteUnformatted, &scope); // Pack the special procedure bindings in ascending order of their "which" // code values, and compile a little-endian bit-set of those codes for // use in O(1) look-up at run time. @@ -1072,8 +1068,9 @@ } void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces( - std::map &specials, SourceName name, + std::map &specials, GenericKind::DefinedIo definedIo, const Scope *scope) { + SourceName name{GenericKind::AsFortran(definedIo)}; for (; !scope->IsGlobal(); scope = &scope->parent()) { if (auto asst{scope->find(name)}; asst != scope->end()) { const Symbol &generic{asst->second->GetUltimate()}; Index: flang/lib/Semantics/symbol.cpp =================================================================== --- flang/lib/Semantics/symbol.cpp +++ flang/lib/Semantics/symbol.cpp @@ -13,6 +13,7 @@ #include "flang/Semantics/semantics.h" #include "flang/Semantics/tools.h" #include "llvm/Support/raw_ostream.h" +#include #include #include @@ -657,7 +658,7 @@ return std::visit( common::visitors { [](const OtherKind &x) { return EnumToString(x); }, - [](const DefinedIo &x) { return EnumToString(x); }, + [](const DefinedIo &x) { return AsFortran(x).ToString(); }, #if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2 [](const common::NumericOperator &x) { return common::EnumToString(x); @@ -675,13 +676,32 @@ u); } +SourceName GenericKind::AsFortran(DefinedIo x) { + const char *name{nullptr}; + switch (x) { + SWITCH_COVERS_ALL_CASES + case DefinedIo::ReadFormatted: + name = "read(formatted)"; + break; + case DefinedIo::ReadUnformatted: + name = "read(unformatted)"; + break; + case DefinedIo::WriteFormatted: + name = "write(formatted)"; + break; + case DefinedIo::WriteUnformatted: + name = "write(unformatted)"; + break; + } + return {name, std::strlen(name)}; +} + bool GenericKind::Is(GenericKind::OtherKind x) const { const OtherKind *y{std::get_if(&u)}; return y && *y == x; } -bool SymbolOffsetCompare::operator()( - const SymbolRef &x, const SymbolRef &y) const { +bool SymbolOffsetCompare::operator()(const SymbolRef &x, const SymbolRef &y) const { const Symbol *xCommon{FindCommonBlockContaining(*x)}; const Symbol *yCommon{FindCommonBlockContaining(*y)}; if (xCommon) { @@ -709,6 +729,7 @@ return x->GetSemanticsContext().allCookedSources().Precedes( x->name(), y->name()); } + bool SymbolOffsetCompare::operator()( const MutableSymbolRef &x, const MutableSymbolRef &y) const { return (*this)(SymbolRef{*x}, SymbolRef{*y}); Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -1273,6 +1273,12 @@ return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable); } +DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent( + const DerivedTypeSpec &derived) { + DirectComponentIterator directs{derived}; + return std::find_if(directs.begin(), directs.end(), IsAllocatableOrPointer); +} + UltimateComponentIterator::const_iterator FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) { UltimateComponentIterator ultimates{derived}; @@ -1458,4 +1464,75 @@ return shape ? ToArraySpec(context, *shape) : std::nullopt; } +bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived, + const Scope *scope) { + if (const Scope * dtScope{derived.scope()}) { + for (const auto &pair : *dtScope) { + const Symbol &symbol{*pair.second}; + if (const auto *generic{symbol.detailsIf()}) { + GenericKind kind{generic->kind()}; + if (const auto *io{std::get_if(&kind.u)}) { + if (*io == which) { + return true; // type-bound GENERIC exists + } + } + } + } + } + if (scope) { + SourceName name{GenericKind::AsFortran(which)}; + evaluate::DynamicType dyDerived{derived}; + for (; scope && !scope->IsGlobal(); scope = &scope->parent()) { + auto iter{scope->find(name)}; + if (iter != scope->end()) { + const auto &generic{iter->second->GetUltimate().get()}; + for (auto ref : generic.specificProcs()) { + const Symbol &procSym{ref->GetUltimate()}; + if (const auto *subp{procSym.detailsIf()}) { + if (!subp->dummyArgs().empty()) { + if (const Symbol * first{subp->dummyArgs().at(0)}) { + if (const DeclTypeSpec * dtSpec{first->GetType()}) { + if (auto dyDummy{evaluate::DynamicType::From(*dtSpec)}) { + if (dyDummy->IsTkCompatibleWith(dyDerived)) { + return true; // GENERIC or INTERFACE not in type + } + } + } + } + } + } + } + } + } + } + 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 =================================================================== --- /dev/null +++ flang/test/Semantics/io12.f90 @@ -0,0 +1,76 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Tests for I/O of derived types without defined I/O procedures +! but with exposed allocatable/pointer components that would fail +! at run time. + +module m1 + type :: poison + real, allocatable :: allocatableComponent(:) + end type + type :: ok + integer :: x + type(poison) :: pill + contains + procedure :: wuf1 + generic :: write(unformatted) => wuf1 + end type + type :: maybeBad + integer :: x + type(poison) :: pill + end type + contains + subroutine wuf1(dtv, unit, iostat, iomsg) + class(ok), intent(in) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(*), intent(in out) :: iomsg + write(unit) dtv%x + end subroutine +end module + +module m2 + use m1 + interface write(unformatted) + module procedure wuf2 + end interface + contains + subroutine wuf2(dtv, unit, iostat, iomsg) + class(maybeBad), intent(in) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(*), intent(in out) :: iomsg + write(unit) dtv%x + end subroutine +end module + +module m3 + use m1 + contains + subroutine test3(u) + integer, intent(in) :: u + type(ok) :: x + 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 + write(u) y ! bad here + !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O + write(u) z ! bad + end subroutine +end module + +module m4 + use m2 + contains + subroutine test4(u) + integer, intent(in) :: u + type(ok) :: x + type(maybeBad) :: y + 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 + write(u) z ! bad + end subroutine +end module +