diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 7732cbff4faef..821dff1e429f9 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -165,8 +165,8 @@ class CheckHelper { void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &); void CheckDioDummyIsScalar(const Symbol &, const Symbol &); void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr); - void CheckDioDtvArg( - const Symbol &, const Symbol *, common::DefinedIo, const Symbol &); + void CheckDioDtvArg(const Symbol &proc, const Symbol &subp, const Symbol *arg, + common::DefinedIo, const Symbol &generic); void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &); void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr); void CheckDioAssumedLenCharacterArg( @@ -3429,11 +3429,17 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType, if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end() && IsAccessible(*iter->second, generic.owner())) { for (auto specRef : iter->second->get().specificProcs()) { - const Symbol &specific{specRef->get().symbol()}; - if (specific == proc) { + const Symbol *specific{&specRef->get().symbol()}; + if (specific == &proc) { continue; // unambiguous, accept } - if (const auto *specDT{GetDtvArgDerivedType(specific)}; + if (const auto *peDetails{specific->detailsIf()}) { + specific = peDetails->procInterface(); + if (!specific) { + continue; + } + } + if (const auto *specDT{GetDtvArgDerivedType(*specific)}; specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) { SayWithDeclaration(*specRef, proc.name(), "Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US, @@ -3445,11 +3451,11 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType, } } -void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg, +void CheckHelper::CheckDioDummyIsDerived(const Symbol &proc, const Symbol &arg, common::DefinedIo ioKind, const Symbol &generic) { if (const DeclTypeSpec *type{arg.GetType()}) { if (const DerivedTypeSpec *derivedType{type->AsDerived()}) { - CheckAlreadySeenDefinedIo(*derivedType, ioKind, subp, generic); + CheckAlreadySeenDefinedIo(*derivedType, ioKind, proc, generic); bool isPolymorphic{type->IsPolymorphic()}; if (isPolymorphic != IsExtensibleType(derivedType)) { messages_.Say(arg.name(), @@ -3487,11 +3493,11 @@ void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) { } } -void CheckHelper::CheckDioDtvArg(const Symbol &subp, const Symbol *arg, - common::DefinedIo ioKind, const Symbol &generic) { +void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp, + const Symbol *arg, common::DefinedIo ioKind, const Symbol &generic) { // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv if (CheckDioDummyIsData(subp, arg, 0)) { - CheckDioDummyIsDerived(subp, *arg, ioKind, generic); + CheckDioDummyIsDerived(proc, *arg, ioKind, generic); CheckDioDummyAttrs(subp, *arg, ioKind == common::DefinedIo::ReadFormatted || ioKind == common::DefinedIo::ReadUnformatted @@ -3618,57 +3624,64 @@ void CheckHelper::CheckDefinedIoProc(const Symbol &symbol, for (auto ref : details.specificProcs()) { const Symbol &ultimate{ref->GetUltimate()}; const auto *binding{ultimate.detailsIf()}; - const Symbol &specific{*(binding ? &binding->symbol() : &ultimate)}; if (ultimate.attrs().test(Attr::NOPASS)) { // C774 messages_.Say( "Defined input/output procedure '%s' may not have NOPASS attribute"_err_en_US, ultimate.name()); context_.SetError(ultimate); } - if (const auto *subpDetails{specific.detailsIf()}) { + const Symbol *specificProc{binding ? &binding->symbol() : &ultimate}; + const Symbol *specificSubp{specificProc}; + if (const auto *peDetails{specificSubp->detailsIf()}) { + specificSubp = peDetails->procInterface(); + if (!specificSubp) { + continue; + } + } + if (const auto *subpDetails{specificSubp->detailsIf()}) { const std::vector &dummyArgs{subpDetails->dummyArgs()}; - CheckDioArgCount(specific, ioKind, dummyArgs.size()); + CheckDioArgCount(*specificSubp, ioKind, dummyArgs.size()); int argCount{0}; for (auto *arg : dummyArgs) { switch (argCount++) { case 0: // dtv-type-spec, INTENT(INOUT) :: dtv - CheckDioDtvArg(specific, arg, ioKind, symbol); + CheckDioDtvArg(*specificProc, *specificSubp, arg, ioKind, symbol); break; case 1: // INTEGER, INTENT(IN) :: unit - CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN); + CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_IN); break; case 2: if (ioKind == common::DefinedIo::ReadFormatted || ioKind == common::DefinedIo::WriteFormatted) { // CHARACTER (LEN=*), INTENT(IN) :: iotype CheckDioAssumedLenCharacterArg( - specific, arg, argCount, Attr::INTENT_IN); + *specificSubp, arg, argCount, Attr::INTENT_IN); } else { // INTEGER, INTENT(OUT) :: iostat - CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT); + CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT); } break; case 3: if (ioKind == common::DefinedIo::ReadFormatted || ioKind == common::DefinedIo::WriteFormatted) { // INTEGER, INTENT(IN) :: v_list(:) - CheckDioVlistArg(specific, arg, argCount); + CheckDioVlistArg(*specificSubp, arg, argCount); } else { // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg CheckDioAssumedLenCharacterArg( - specific, arg, argCount, Attr::INTENT_INOUT); + *specificSubp, arg, argCount, Attr::INTENT_INOUT); } break; case 4: // INTEGER, INTENT(OUT) :: iostat - CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT); + CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT); break; case 5: // CHARACTER (LEN=*), INTENT(INOUT) :: iomsg CheckDioAssumedLenCharacterArg( - specific, arg, argCount, Attr::INTENT_INOUT); + *specificSubp, arg, argCount, Attr::INTENT_INOUT); break; default:; } diff --git a/flang/test/Lower/io-derived-type.f90 b/flang/test/Lower/io-derived-type.f90 index 8ac995739afd7..f96feca77c485 100644 --- a/flang/test/Lower/io-derived-type.f90 +++ b/flang/test/Lower/io-derived-type.f90 @@ -22,7 +22,7 @@ subroutine wft(dtv, unit, iotype, v_list, iostat, iomsg) ! CHECK-LABEL: @_QMmPwftd subroutine wftd(dtv, unit, iotype, v_list, iostat, iomsg) - type(t), intent(in) :: dtv + class(t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, intent(in) :: v_list(:) @@ -91,13 +91,13 @@ subroutine test3(p, x) ! CHECK: %[[V_10:[0-9]+]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> !fir.ref ! CHECK: %[[V_11:[0-9]+]] = fir.insert_value %[[V_9]], %[[V_10]], [0 : index, 1 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, !fir.ref) -> !fir.array<1xtuple, !fir.ref, i32, i1>> ! CHECK: %[[V_12:[0-9]+]] = fir.insert_value %[[V_11]], %c2{{.*}}, [0 : index, 2 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, i32) -> !fir.array<1xtuple, !fir.ref, i32, i1>> - ! CHECK: %[[V_13:[0-9]+]] = fir.insert_value %[[V_12]], %false, [0 : index, 3 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, i1) -> !fir.array<1xtuple, !fir.ref, i32, i1>> + ! CHECK: %[[V_13:[0-9]+]] = fir.insert_value %[[V_12]], %true, [0 : index, 3 : index] : (!fir.array<1xtuple, !fir.ref, i32, i1>>, i1) -> !fir.array<1xtuple, !fir.ref, i32, i1>> ! CHECK: fir.store %[[V_13]] to %[[V_5]] : !fir.ref, !fir.ref, i32, i1>>> ! CHECK: %[[V_14:[0-9]+]] = fir.alloca tuple, !fir.ref, i32, i1>>>, i1> ! CHECK: %[[V_15:[0-9]+]] = fir.undefined tuple, !fir.ref, i32, i1>>>, i1> ! CHECK: %[[V_16:[0-9]+]] = fir.insert_value %[[V_15]], %c1{{.*}}, [0 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, i64) -> tuple, !fir.ref, i32, i1>>>, i1> ! CHECK: %[[V_17:[0-9]+]] = fir.insert_value %[[V_16]], %[[V_5]], [1 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, !fir.ref, !fir.ref, i32, i1>>>) -> tuple, !fir.ref, i32, i1>>>, i1> - ! CHECK: %[[V_18:[0-9]+]] = fir.insert_value %[[V_17]], %true, [2 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, i1) -> tuple, !fir.ref, i32, i1>>>, i1> + ! CHECK: %[[V_18:[0-9]+]] = fir.insert_value %[[V_17]], %true_0, [2 : index] : (tuple, !fir.ref, i32, i1>>>, i1>, i1) -> tuple, !fir.ref, i32, i1>>>, i1> ! CHECK: fir.store %[[V_18]] to %[[V_14]] : !fir.ref, !fir.ref, i32, i1>>>, i1>> ! CHECK: %[[V_19:[0-9]+]] = fir.convert %[[V_14]] : (!fir.ref, !fir.ref, i32, i1>>>, i1>>) -> !fir.ref ! CHECK: %[[V_20:[0-9]+]] = fir.call @_FortranAioOutputDerivedType(%{{.*}}, %[[V_4]], %[[V_19]]) fastmath : (!fir.ref, !fir.box, !fir.ref) -> i1 diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90 index 5d3d90271c0a8..7565d35aeb407 100644 --- a/flang/test/Semantics/io11.f90 +++ b/flang/test/Semantics/io11.f90 @@ -720,3 +720,27 @@ subroutine ur2(dtv,unit,iostat,iomsg) read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c end end + +module m28 + type t + contains + procedure, private :: write1 + generic :: write(formatted) => write1 + end type + abstract interface + subroutine absWrite(dtv, unit, iotype, v_list, iostat, iomsg) + import t + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + end + end interface + !ERROR: Derived type 't' has conflicting type-bound input/output procedure 'write(formatted)' + procedure(absWrite) write1, write2 + interface write(formatted) + procedure write2 + end interface +end