[flang-commits] [flang] 22d7e29 - [flang] Check for duplicate definitions of defined input/output procedures
Peter Steinfeld via flang-commits
flang-commits at lists.llvm.org
Thu Jun 3 07:39:46 PDT 2021
Author: Peter Steinfeld
Date: 2021-06-03T07:39:27-07:00
New Revision: 22d7e298dc35a2319d7b71ee78732b0a3a86893d
URL: https://github.com/llvm/llvm-project/commit/22d7e298dc35a2319d7b71ee78732b0a3a86893d
DIFF: https://github.com/llvm/llvm-project/commit/22d7e298dc35a2319d7b71ee78732b0a3a86893d.diff
LOG: [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
Added:
Modified:
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/test/Semantics/io11.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 6633e02cba839..7d83b1b4b530e 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -107,7 +107,8 @@ class CheckHelper {
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 @@ class CheckHelper {
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 @@ class CheckHelper {
characterizeCache_;
// Collection of symbols with BIND(C) names
std::map<std::string, SymbolRef> bindC_;
+ // Derived types that have defined input/output procedures
+ std::vector<TypeWithDefinedIo> 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 9aea0e1faacc0..a31c5291676c2 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 fd1d494da3233..a20b51fdcb39f 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -364,3 +364,253 @@ subroutine formattedReadProc(dtv, unit, iotype, vlist, iostat, iomsg)
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
diff erent 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
diff erent 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
diff erent 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
More information about the flang-commits
mailing list