From 22d7e298dc35a2319d7b71ee78732b0a3a86893d Mon Sep 17 00:00:00 2001 From: Peter Steinfeld Date: Wed, 2 Jun 2021 14:55:41 -0700 Subject: [PATCH] [flang] Check for duplicate definitions of defined input/output procedures It's possible to specify defined input/output procedures either as a type-bound procedure of a derived type or as a defined-io-generic-spec. This means that you can specify the same procedure in both mechanisms, which does not cause problems. Alternatively, you can specify two different procedures to be the defined input/output procedure for the same derived type. This is an error. This change catches this error. The situation is slightly complicated by parameterized derived types. Types with the same value for a KIND parameter are treated as the same type while types with different KIND parameters are treated as different types. I implemented this check by adding a vector to keep track of which defined input/output procedures had been seen for which derived types along with the kind of procedure (read vs write and formatted vs unformatted). I also added tests for non-parameterized types and types parameterized by KIND and LEN type parameters. I also removed an erroneous check from the code that creates runtime type information. Differential Revision: https://reviews.llvm.org/D103560 --- flang/lib/Semantics/check-declarations.cpp | 49 +++- flang/lib/Semantics/runtime-type-info.cpp | 6 - flang/test/Semantics/io11.f90 | 250 +++++++++++++++++++++ 3 files changed, 290 insertions(+), 15 deletions(-) diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 6633e02cba83..7d83b1b4b530 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -107,7 +107,8 @@ private: void CheckDefinedIoProc( const Symbol &, const GenericDetails &, GenericKind::DefinedIo); bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t); - void CheckDioDummyIsDerived(const Symbol &, const Symbol &); + void CheckDioDummyIsDerived( + const Symbol &, const Symbol &, GenericKind::DefinedIo ioKind); void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &); void CheckDioDummyIsScalar(const Symbol &, const Symbol &); void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr); @@ -118,6 +119,13 @@ private: void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t); void CheckDioArgCount( const Symbol &, GenericKind::DefinedIo ioKind, std::size_t); + struct TypeWithDefinedIo { + const DerivedTypeSpec *type; + GenericKind::DefinedIo ioKind; + const Symbol &proc; + }; + void CheckAlreadySeenDefinedIo( + const DerivedTypeSpec *, GenericKind::DefinedIo, const Symbol &); SemanticsContext &context_; evaluate::FoldingContext &foldingContext_{context_.foldingContext()}; @@ -132,6 +140,8 @@ private: characterizeCache_; // Collection of symbols with BIND(C) names std::map bindC_; + // Derived types that have defined input/output procedures + std::vector seenDefinedIoTypes_; }; class DistinguishabilityHelper { @@ -1742,15 +1752,36 @@ bool CheckHelper::CheckDioDummyIsData( } } +void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec *derivedType, + GenericKind::DefinedIo ioKind, const Symbol &proc) { + for (TypeWithDefinedIo definedIoType : seenDefinedIoTypes_) { + if (*derivedType == *definedIoType.type && ioKind == definedIoType.ioKind && + proc != definedIoType.proc) { + SayWithDeclaration(proc, definedIoType.proc.name(), + "Derived type '%s' already has defined input/output procedure" + " '%s'"_err_en_US, + derivedType->name(), + parser::ToUpperCaseLetters(GenericKind::EnumToString(ioKind))); + return; + } + } + seenDefinedIoTypes_.emplace_back( + TypeWithDefinedIo{derivedType, ioKind, proc}); +} + void CheckHelper::CheckDioDummyIsDerived( - const Symbol &subp, const Symbol &arg) { - if (const DeclTypeSpec * type{arg.GetType()}; type && type->AsDerived()) { - return; + const Symbol &subp, const Symbol &arg, GenericKind::DefinedIo ioKind) { + if (const DeclTypeSpec * type{arg.GetType()}) { + const DerivedTypeSpec *derivedType{type->AsDerived()}; + if (derivedType) { + CheckAlreadySeenDefinedIo(derivedType, ioKind, subp); + } else { + messages_.Say(arg.name(), + "Dummy argument '%s' of a defined input/output procedure must have a" + " derived type"_err_en_US, + arg.name()); + } } - messages_.Say(arg.name(), - "Dummy argument '%s' of a defined input/output procedure must have a" - " derived type"_err_en_US, - arg.name()); } void CheckHelper::CheckDioDummyIsDefaultInteger( @@ -1781,7 +1812,7 @@ void CheckHelper::CheckDioDtvArg( const Symbol &subp, const Symbol *arg, GenericKind::DefinedIo ioKind) { // Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv if (CheckDioDummyIsData(subp, arg, 0)) { - CheckDioDummyIsDerived(subp, *arg); + CheckDioDummyIsDerived(subp, *arg, ioKind); CheckDioDummyAttrs(subp, *arg, ioKind == GenericKind::DefinedIo::ReadFormatted || ioKind == GenericKind::DefinedIo::ReadUnformatted diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp index 9aea0e1faacc..a31c5291676c 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -886,12 +886,6 @@ void RuntimeTableBuilder::DescribeSpecialProc( } } else { // user defined derived type I/O CHECK(proc->dummyArguments.size() >= 4); - bool isArg0Descriptor{ - !proc->dummyArguments.at(0).CanBePassedViaImplicitInterface()}; - // N.B. When the user defined I/O subroutine is a type bound procedure, - // its first argument is always a descriptor, otherwise, when it was an - // interface, it never is. - CHECK(!!binding == isArg0Descriptor); if (binding) { isArgDescriptorSet |= 1; } diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90 index fd1d494da323..a20b51fdcb39 100644 --- a/flang/test/Semantics/io11.f90 +++ b/flang/test/Semantics/io11.f90 @@ -364,3 +364,253 @@ contains stop 'fail' end subroutine end module m16 + +module m17 + ! Test the same defined input/output procedure specified as a generic + type t + integer c + contains + procedure :: formattedReadProc + end type + + interface read(formatted) + module procedure formattedReadProc + end interface + +contains + subroutine formattedReadProc(dtv,unit,iotype,v_list,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + character(*),intent(in) :: iotype + integer,intent(in) :: v_list(:) + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m18 + ! Test the same defined input/output procedure specified as a type-bound + ! procedure and as a generic + type t + integer c + contains + procedure :: formattedReadProc + generic :: read(formatted) => formattedReadProc + end type + interface read(formatted) + module procedure formattedReadProc + end interface +contains + subroutine formattedReadProc(dtv,unit,iotype,v_list,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + character(*),intent(in) :: iotype + integer,intent(in) :: v_list(:) + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m19 + ! Test two different defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type + type t + integer c + contains + procedure :: unformattedReadProc1 + generic :: read(unformatted) => unformattedReadProc1 + end type + interface read(unformatted) + module procedure unformattedReadProc + end interface +contains + subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED' + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m20 + ! Test read and write defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type + type t + integer c + contains + procedure :: unformattedReadProc + generic :: read(unformatted) => unformattedReadProc + end type + interface read(unformatted) + module procedure unformattedReadProc + end interface + interface write(unformatted) + module procedure unformattedWriteProc + end interface +contains + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + subroutine unformattedWriteProc(dtv,unit,iostat,iomsg) + class(t),intent(in) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + write(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m21 + ! Test read and write defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type with a + ! KIND type parameter where they both have the same value + type t(typeParam) + integer, kind :: typeParam = 4 + integer c + contains + procedure :: unformattedReadProc + generic :: read(unformatted) => unformattedReadProc + end type + interface read(unformatted) + module procedure unformattedReadProc1 + end interface +contains + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED' + subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) + class(t(4)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m22 + ! Test read and write defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type with a + ! KIND type parameter where they have different values + type t(typeParam) + integer, kind :: typeParam = 4 + integer c + contains + procedure :: unformattedReadProc + generic :: read(unformatted) => unformattedReadProc + end type + interface read(unformatted) + module procedure unformattedReadProc1 + end interface +contains + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) + class(t(3)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m23 + type t(typeParam) + ! Test read and write defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type with a + ! LEN type parameter where they have different values + integer, len :: typeParam = 4 + integer c + contains + procedure :: unformattedReadProc + generic :: read(unformatted) => unformattedReadProc + end type + interface read(unformatted) + module procedure unformattedReadProc1 + end interface +contains + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t(*)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) + class(t(3)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module + +module m24 + ! Test read and write defined input/output procedures specified as a + ! type-bound procedure and as a generic for the same derived type with a + ! LEN type parameter where they have the same value + type t(typeParam) + integer, len :: typeParam = 4 + integer c + contains + procedure :: unformattedReadProc + generic :: read(unformatted) => unformattedReadProc + end type + interface read(unformatted) + module procedure unformattedReadProc1 + end interface +contains + subroutine unformattedReadProc(dtv,unit,iostat,iomsg) + class(t(*)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine + !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED' + subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) + class(t(*)),intent(inout) :: dtv + integer,intent(in) :: unit + integer,intent(out) :: iostat + character(*),intent(inout) :: iomsg + read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c + print *,v_list + end subroutine +end module -- GitLab