From 45ac2c730bc4f78d2d90a76e98fab66de92433b6 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Tue, 3 May 2022 09:54:29 -0700
Subject: [PATCH] [flang] Allow PDTs with LEN parameters in REDUCE()

The type compatibility checks for the ARRAY= argument and the dummy
arguments and result of the OPERATION= argument to the REDUCE intrinsic
function need to allow for parameterized data types with LEN parameters.
(Their values are required to be identical but this is not a numbered
constraint requiring a compilation time check).

Differential Revision: https://reviews.llvm.org/D125124
---
 flang/lib/Evaluate/intrinsics.cpp |  4 ++--
 flang/test/Semantics/reduce01.f90 | 15 ++++++++++++++-
 2 files changed, 16 insertions(+), 3 deletions(-)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 83c505353988..c6617f797356 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2393,7 +2393,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
         context.messages().Say(at,
             "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
       } else if (result->type().IsPolymorphic() ||
-          result->type() != *arrayType) {
+          !arrayType->IsTkCompatibleWith(result->type())) {
         ok = false;
         context.messages().Say(at,
             "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);
@@ -2418,7 +2418,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
                     characteristics::DummyDataObject::Attr::Pointer) &&
                 data[j]->type.Rank() == 0 &&
                 !data[j]->type.type().IsPolymorphic() &&
-                data[j]->type.type() == *arrayType;
+                data[j]->type.type().IsTkCompatibleWith(*arrayType);
           }
           if (!ok) {
             context.messages().Say(at,
diff --git a/flang/test/Semantics/reduce01.f90 b/flang/test/Semantics/reduce01.f90
index 9e6fffcc091f..fe58004ff30a 100644
--- a/flang/test/Semantics/reduce01.f90
+++ b/flang/test/Semantics/reduce01.f90
@@ -1,5 +1,9 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
 module m
+  type :: pdt(len)
+    integer, len :: len
+    character(len=len) :: ch
+  end type
  contains
   impure real function f1(x,y)
     f1 = x + y
@@ -48,8 +52,13 @@ module m
     real, intent(in) :: y
     f10 = x + y
   end function
+  pure function f11(x,y) result(res)
+    type(pdt(*)), intent(in) :: x, y
+    type(pdt(max(x%len, y%len))) :: res
+    res%ch = x%ch // y%ch
+  end function
 
-  subroutine test
+  subroutine errors
     real :: a(10,10), b
     !ERROR: OPERATION= argument of REDUCE() must be a pure function of two data arguments
     b = reduce(a, f1)
@@ -72,4 +81,8 @@ module m
     !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute
     b = reduce(a, f10)
   end subroutine
+  subroutine not_errors
+    type(pdt(10)) :: a(10), b
+    b = reduce(a, f11) ! check no bogus type incompatibility diagnostic
+  end subroutine
 end module