[flang] Fix bogus error about procedure incompatbility (#107645)

This was a subtle problem. When the shape of a function result is
explicit but not constant, it is characterized with bounds expressions
that use Extremum<SubscriptInteger> operations to force extents to 0
rather than be negative. These Extremum operations are formatted as
"max()" intrinsic functions in the module file. Upon being read from the
module file, they are not folded back into Extremum operations, but
remain as function references; and this then leads to expressions not
comparing equal when the procedure characteristics are compared to those
of a local procedure declared identically.

The real fix here would be for folding to just always change max and min
function references into Extremum<> operations, constant operands or
not, and I tried that, but it lead to test failures and crashes in
lowering that I couldn't resolve. So, until those can be fixed, here's a
change that will read max/min operations in module file declarations
back into Extremum operations to solve the compatibility checking
problem, but leave other non-constant max/min operations as function
calls.

Author: klausler

flang/include/flang/Evaluate/expression.h

@@ -342,6 +342,7 @@ template <typename A> struct Extremum : public Operation<Extremum<A>, A, A, A> {
       : Base{x, y}, ordering{ord} {}
   Extremum(Ordering ord, Expr<Operand> &&x, Expr<Operand> &&y)
       : Base{std::move(x), std::move(y)}, ordering{ord} {}
+  bool operator==(const Extremum &) const;
   Ordering ordering{Ordering::Greater};
 };
 
@@ -381,6 +382,7 @@ struct LogicalOperation
       : Base{x, y}, logicalOperator{opr} {}
   LogicalOperation(LogicalOperator opr, Expr<Operand> &&x, Expr<Operand> &&y)
       : Base{std::move(x), std::move(y)}, logicalOperator{opr} {}
+  bool operator==(const LogicalOperation &) const;
   LogicalOperator logicalOperator;
 };
 
@@ -634,6 +636,7 @@ class Relational : public Operation<Relational<T>, LogicalResult, T, T> {
       : Base{a, b}, opr{r} {}
   Relational(RelationalOperator r, Expr<Operand> &&a, Expr<Operand> &&b)
       : Base{std::move(a), std::move(b)}, opr{r} {}
+  bool operator==(const Relational &) const;
   RelationalOperator opr;
 };
 

flang/include/flang/Evaluate/tools.h

@@ -218,6 +218,22 @@ template <typename A, typename B> A *UnwrapExpr(std::optional<B> &x) {
   }
 }
 
+template <typename A, typename B> const A *UnwrapExpr(const B *x) {
+  if (x) {
+    return UnwrapExpr<A>(*x);
+  } else {
+    return nullptr;
+  }
+}
+
+template <typename A, typename B> A *UnwrapExpr(B *x) {
+  if (x) {
+    return UnwrapExpr<A>(*x);
+  } else {
+    return nullptr;
+  }
+}
+
 // A variant of UnwrapExpr above that also skips through (parentheses)
 // and conversions of kinds within a category.  Useful for extracting LEN
 // type parameter inquiries, at least.

flang/lib/Evaluate/expression.cpp

@@ -125,6 +125,24 @@ template <typename A> LLVM_DUMP_METHOD void ExpressionBase<A>::dump() const {
 
 // Equality testing
 
+template <typename A> bool Extremum<A>::operator==(const Extremum &that) const {
+  return ordering == that.ordering && Base::operator==(that);
+}
+
+template <int KIND>
+bool LogicalOperation<KIND>::operator==(const LogicalOperation &that) const {
+  return logicalOperator == that.logicalOperator && Base::operator==(that);
+}
+
+template <typename A>
+bool Relational<A>::operator==(const Relational &that) const {
+  return opr == that.opr && Base::operator==(that);
+}
+
+bool Relational<SomeType>::operator==(const Relational &that) const {
+  return u == that.u;
+}
+
 bool ImpliedDoIndex::operator==(const ImpliedDoIndex &that) const {
   return name == that.name;
 }
@@ -181,10 +199,6 @@ bool StructureConstructor::operator==(const StructureConstructor &that) const {
   return result_ == that.result_ && values_ == that.values_;
 }
 
-bool Relational<SomeType>::operator==(const Relational<SomeType> &that) const {
-  return u == that.u;
-}
-
 template <int KIND>
 bool Expr<Type<TypeCategory::Integer, KIND>>::operator==(
     const Expr<Type<TypeCategory::Integer, KIND>> &that) const {

flang/lib/Evaluate/fold-implementation.h

@@ -1088,24 +1088,42 @@ Expr<T> FoldMINorMAX(
   static_assert(T::category == TypeCategory::Integer ||
       T::category == TypeCategory::Real ||
       T::category == TypeCategory::Character);
-  std::vector<Constant<T> *> constantArgs;
-  // Call Folding on all arguments, even if some are not constant,
-  // to make operand promotion explicit.
-  for (auto &arg : funcRef.arguments()) {
-    if (auto *cst{Folder<T>{context}.Folding(arg)}) {
-      constantArgs.push_back(cst);
+  auto &args{funcRef.arguments()};
+  bool ok{true};
+  std::optional<Expr<T>> result;
+  Folder<T> folder{context};
+  for (std::optional<ActualArgument> &arg : args) {
+    // Call Folding on all arguments to make operand promotion explicit.
+    if (!folder.Folding(arg)) {
+      // TODO: Lowering can't handle having every FunctionRef for max and min
+      // being converted into Extremum<T>.  That needs fixing.  Until that
+      // is corrected, however, it is important that max and min references
+      // in module files be converted into Extremum<T> even when not constant;
+      // the Extremum<SubscriptInteger> operations created to normalize the
+      // values of array bounds are formatted as max operations in the
+      // declarations in modules, and need to be read back in as such in
+      // order for expression comparison to not produce false inequalities
+      // when checking function results for procedure interface compatibility.
+      if (!context.moduleFileName()) {
+        ok = false;
+      }
+    }
+    Expr<SomeType> *argExpr{arg ? arg->UnwrapExpr() : nullptr};
+    if (argExpr) {
+      *argExpr = Fold(context, std::move(*argExpr));
+    }
+    if (Expr<T> * tExpr{UnwrapExpr<Expr<T>>(argExpr)}) {
+      if (result) {
+        result = FoldOperation(
+            context, Extremum<T>{order, std::move(*result), Expr<T>{*tExpr}});
+      } else {
+        result = Expr<T>{*tExpr};
+      }
+    } else {
+      ok = false;
     }
   }
-  if (constantArgs.size() != funcRef.arguments().size()) {
-    return Expr<T>(std::move(funcRef));
-  }
-  CHECK(!constantArgs.empty());
-  Expr<T> result{std::move(*constantArgs[0])};
-  for (std::size_t i{1}; i < constantArgs.size(); ++i) {
-    Extremum<T> extremum{order, result, Expr<T>{std::move(*constantArgs[i])}};
-    result = FoldOperation(context, std::move(extremum));
-  }
-  return result;
+  return ok && result ? std::move(*result) : Expr<T>{std::move(funcRef)};
 }
 
 // For AMAX0, AMIN0, AMAX1, AMIN1, DMAX1, DMIN1, MAX0, MIN0, MAX1, and MIN1

flang/test/Semantics/Inputs/modfile67.mod

@@ -0,0 +1,16 @@
+!mod$ v1 sum:37cfecee3234c8ab
+module modfile67
+type::t
+procedure(foo),nopass,pointer::p
+end type
+contains
+pure function foo(n,a) result(r)
+integer(4),intent(in)::n
+real(4),intent(in)::a(1_8:int(n,kind=8))
+logical(4)::r(1_8:int(int(max(0_8,int(n,kind=8)),kind=4),kind=8))
+end
+function fooptr(f)
+procedure(foo)::f
+type(t)::fooptr
+end
+end

flang/test/Semantics/modfile67.f90

@@ -0,0 +1,35 @@
+!RUN: %flang_fc1 -fsyntax-only -J%S/Inputs %s
+
+#if 0
+!modfile67.mod was produced from this source, and must be read into this
+!compilation from its module file in order to truly test this fix.
+module modfile67
+  type t
+    procedure(foo), nopass, pointer :: p
+  end type
+ contains
+  pure function foo(n,a) result(r)
+    integer, intent(in) :: n
+    real, intent(in), dimension(n) :: a
+    logical, dimension(size(a)) :: r
+    r = .false.
+  end
+  type(t) function fooptr(f)
+    procedure(foo) f
+    fooptr%p => f
+  end
+end
+#endif
+
+program test
+  use modfile67
+  type(t) x
+  x = fooptr(bar) ! ensure no bogus error about procedure incompatibility
+ contains
+  pure function bar(n,a) result(r)
+    integer, intent(in) :: n
+    real, intent(in), dimension(n) :: a
+    logical, dimension(size(a)) :: r
+    r = .false.
+  end
+end