[flang-commits] [flang] [flang] Silence bogus error message (PR #111057)

[Peter Klausler via flang-commits]

https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/111057

>From 23d8b8add61cb37d1ee399bc85485a103a3c7534 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 3 Oct 2024 13:17:40 -0700
Subject: [PATCH] [flang] Silence bogus error message

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.
---
 flang/lib/Semantics/tools.cpp |  4 +++-
 flang/test/Semantics/io14.f90 | 11 +++++------
 2 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 3723b28fecef52..904d43de091380 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 6dd6763bc944b9..39f91f5bd2752b 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 @@ subroutine fwrite(x, unit, iotype, vlist, iostat, iomsg)
     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