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

[via flang-commits]

Author: Peter Klausler
Date: 2024-10-07T13:17:28-07:00
New Revision: 49016d53e8f54d4b0883f4fcb06800bcfd7bd40e

URL: https://github.com/llvm/llvm-project/commit/49016d53e8f54d4b0883f4fcb06800bcfd7bd40e
DIFF: https://github.com/llvm/llvm-project/commit/49016d53e8f54d4b0883f4fcb06800bcfd7bd40e.diff

LOG: [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.

Added: 
    

Modified: 
    flang/lib/Semantics/tools.cpp
    flang/test/Semantics/io14.f90

Removed: 
    


################################################################################
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