[flang] Silence bogus error message (#111057)

Fortran doesn't permit the use of a polymorphic I/O list item for
intrinsic data transfers, so the compiler emits an error message for
polymorphic items whose types can't possibly be handled by a defined I/O
subroutine. This check didn't allow for the possibility that the defined
I/O subroutine might apply to the parent component of an extended type.

Fixes https://github.com/llvm/llvm-project/issues/111021.

2 files changed, 8 insertions, 7 deletions

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 3723b28..904d43d 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1649,7 +1649,9 @@ bool HasDefinedIo(common::DefinedIo which, const DerivedTypeSpec &derived,
       }
     }
   }
-  return false;
+  // Check for inherited defined I/O
+  const auto *parentType{derived.typeSymbol().GetParentTypeSpec()};
+  return parentType && HasDefinedIo(which, *parentType, scope);
 }
 
 void WarnOnDeferredLengthCharacterScalar(SemanticsContext &context,
diff --git a/flang/test/Semantics/io14.f90 b/flang/test/Semantics/io14.f90
index 6dd6763..39f91f5 100644
--- a/flang/test/Semantics/io14.f90
+++ b/flang/test/Semantics/io14.f90
@@ -9,6 +9,8 @@ module m
     procedure :: fwrite
     generic :: write(formatted) => fwrite
   end type
+  type, extends(t) :: t2
+  end type
  contains
   subroutine fwrite(x, unit, iotype, vlist, iostat, iomsg)
     class(t), intent(in) :: x
@@ -19,19 +21,16 @@ module m
     character(*), intent(in out) :: iomsg
     write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%n, ')'
   end subroutine
-  subroutine subr(x, y, z)
+  subroutine subr(x, y, z, w)
     class(t), intent(in) :: x
     class(base), intent(in) :: y
     class(*), intent(in) :: z
+    class(t2), intent(in) :: w
     print *, x ! ok
+    print *, w ! ok
     !ERROR: Derived type 'base' in I/O may not be polymorphic unless using defined I/O
     print *, y
     !ERROR: I/O list item may not be unlimited polymorphic
     print *, z
   end subroutine
 end
-
-program main
-  use m
-  call subr(t(123),t(234),t(345))
-end