[flang] Check for duplicate definitions of defined input/output procedures

[PeteSteinfeld]

Summary

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.

[klausler]

flang/lib/Semantics/check-declarations.cpp

1769

I think you don't need or even want the TypeWithDefinedIo constructor here; just list the arguments. Otherwise it's a copy of a constructed value, not construction in place.

[PeteSteinfeld]

flang/lib/Semantics/check-declarations.cpp

1769

Thanks, Peter.

I can't figure out how to get rid of the name of the type and get things to compile. I get an error message from G++ that says "no matching function ..."

[jeanPerier]

Looks good to me

flang/lib/Semantics/check-declarations.cpp

void SayWithDeclaration(const Symbol &symbol, A &&...x) {
     }
   }
   bool IsResultOkToDiffer(const FunctionResult &);
   void CheckBindCName(const Symbol &);
   // Check functions for defined I/O procedures
   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);
   void CheckDioDtvArg(const Symbol &, const Symbol *, GenericKind::DefinedIo);
   void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
   void CheckDioAssumedLenCharacterArg(
       const Symbol &, const Symbol *, std::size_t, Attr);
   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()};
   parser::ContextualMessages &messages_{foldingContext_.messages()};
   const Scope *scope_{nullptr};
   bool scopeIsUninstantiatedPDT_{false};
   // This symbol is the one attached to the innermost enclosing scope
   // that has a symbol.
   const Symbol *innermostSymbol_{nullptr};
   // Cache of calls to Procedure::Characterize(Symbol)
   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
       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 {
 public:
   DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
   void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
   void Check(const Scope &);
 
if (arg) {
       messages_.Say(subp.name(),
           "Dummy argument %d of '%s' must be a data object"_err_en_US, position,
           subp.name());
     }
     return false;
   }
 }
 
-void CheckHelper::CheckDioDummyIsDerived(
-    const Symbol &subp, const Symbol &arg) {
-  if (const DeclTypeSpec * type{arg.GetType()}; type && type->AsDerived()) {
+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, 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());
     }
+  }
+}
 
 void CheckHelper::CheckDioDummyIsDefaultInteger(
     const Symbol &subp, const Symbol &arg) {
   if (const DeclTypeSpec * type{arg.GetType()};
       type && type->IsNumeric(TypeCategory::Integer)) {
     if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
         kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
       return;
messages_.Say(arg.name(),
         arg.name());
   }
 }
 
 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
             ? Attr::INTENT_INOUT
             : Attr::INTENT_IN);
   }
 }
 

flang/lib/Semantics/runtime-type-info.cpp

if (isAssignment) { // only type-bound asst's are germane to runtime
           rank = evaluate::GetRank(typeAndShape.shape());
           if (rank > 0) {
             argThatMightBeDescriptor = 1;
           }
         }
       }
     } 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;
       }
       switch (io.value()) {
       case GenericKind::DefinedIo::ReadFormatted:
         which = readFormattedEnum_;
         break;
       case GenericKind::DefinedIo::ReadUnformatted:

flang/test/Semantics/io11.f90

subroutine formattedReadProc(dtv, unit, iotype, vlist, iostat, iomsg)
     integer, intent(in) :: vlist(5)
     integer, intent(out) :: iostat
     character(len=*), intent(inout) :: iomsg
 
     iostat = 343
     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