[flang][RFC] Support arguments rank mismatch

[peixin]

Summary

As F2018 15.4.3.2 (6), the specification part of an interface body may
specify attributes or define values for data entities that do not
determine characteristics of the procedure. Such specifications have no
effect.

The case of passing arguments of rank mismatch hits one assert when
the actual argument is assumed-shape array and the dummy has different
rank. The case is from one actual workload GSI:
https://github.com/NOAA-EMC/GSI/blob/48d8676e870a6493ad6972c3785ef4493ab5d5d9/src/gsi/m_rerank.f90#L283-L291

Support this by reboxing the actual argument with the dummy argument
shape.

Fixes #57620.

[klausler]

The program is non-conforming and non-portable. The characteristics of the dummy argument "i2" in the explicit interface ext_interface affect the characteristics of the procedure because i2 is a dummy argument.

[peixin]

Thanks @klausler for the explanations.

The fix for the Fortran source code has been proposed in https://github.com/llvm/llvm-project/issues/57620#issuecomment-1277138294 and submitted to NOAA (owner of GSI) (https://github.com/NOAA-EMC/GSI/pull/489). I had planned to close this PR after updating from NOAA, but it is inactive since Aug 27, 2022 and the review may take a long time.

Abandon this PR and will update the issue #57620 after having updates from NOAA.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

if (auto boxType = toTy.dyn_cast<fir::BoxCharType>()) {
       mlir::Value unknownLen = create<fir::UndefOp>(loc, getIndexType());
       fir::factory::CharacterExprHelper charHelper{*this, loc};
       return charHelper.createEmboxChar(charBase, unknownLen);
     }
   }
   if (fir::isa_ref_type(toTy) && fir::isa_box_type(fromTy)) {
     // Call is expecting a raw data pointer, not a box. Get the data pointer out
     // of the box and pass that.
-    assert((fir::unwrapRefType(toTy) ==
-                fir::unwrapRefType(fir::unwrapPassByRefType(fromTy)) &&
-            "element types expected to match"));
+    mlir::Type toEleTy = fir::unwrapRefType(toTy);
+    mlir::Type fromEleTy = fir::unwrapRefType(fir::unwrapPassByRefType(fromTy));
+    if (toEleTy != fromEleTy && toEleTy.isa<fir::SequenceType>() &&
+        fromEleTy.isa<fir::SequenceType>()) {
+      auto seqTy = toEleTy.dyn_cast<fir::SequenceType>();
+      llvm::SmallVector<mlir::Value> extents =
+          fir::factory::createExtents(*this, loc, seqTy);
+      auto shapeTy = fir::ShapeType::get(getContext(), extents.size());
+      mlir::Value shape = create<fir::ShapeOp>(loc, shapeTy, extents);
+      mlir::Value newBoxVal = create<fir::ReboxOp>(
+          loc, fir::BoxType::get(seqTy), val, shape, /*slice=*/mlir::Value{});
+      return create<fir::BoxAddrOp>(loc, toTy, newBoxVal);
+    }
+    assert(toEleTy == fromEleTy && "element types expected to match");
     return create<fir::BoxAddrOp>(loc, toTy, val);
   }
 
   return createConvert(loc, toTy, val);
 }
 
 mlir::Value fir::FirOpBuilder::createConvert(mlir::Location loc,
                                              mlir::Type toTy, mlir::Value val) {

flang/test/Lower/arg-rank-mismatch.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func.func @_QMm_testPtest_func(
+! CHECK-SAME:                                 %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xf32>> {fir.bindc_name = "i2", fir.target}) -> !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+! CHECK:         %[[VAL_16:.*]] = fir.undefined index
+! CHECK:         %[[VAL_17:.*]] = fir.shape %[[VAL_16]] : (index) -> !fir.shape<1>
+! CHECK:         %[[VAL_18:.*]] = fir.rebox %[[VAL_0]](%[[VAL_17]]) : (!fir.box<!fir.array<?x?xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK:         %[[VAL_19:.*]] = fir.box_addr %[[VAL_18]] : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>>
+! CHECK:         %[[VAL_20:.*]] = fir.call @_QPext_interface(%{{.*}}, %[[VAL_19]]) : (!fir.ref<i32>, !fir.ref<!fir.array<?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:       }
+
+module  m_test
+  implicit none
+  private
+  public :: test
+
+  interface test
+     module procedure test_func
+  end interface test
+
+CONTAINS
+
+  function test_func(i2) result(i1)
+    implicit none
+    real,dimension(:,:),target,intent(in):: i2
+    real,pointer,dimension(:):: i1
+
+    interface
+       function ext_interface(ln,i2) result(i1)
+       implicit none
+       integer,intent(in) :: ln
+       real,dimension(:,:),target,intent(in):: i2
+       real,pointer,dimension(:):: i1
+       end function ext_interface
+    end interface
+
+    i1 => ext_interface(size(i2),i2)
+  end
+end
+
+program main
+  use m_test
+  real, target :: a(2,2) = reshape([1.,2.,3.,4.], [2,2])
+  real,pointer,dimension(:):: t
+  t=>test(a)
+end
+
+function ext_interface(ln,i2) result(i1)
+  implicit none
+  integer,intent(in) :: ln
+  real,dimension(ln),target,intent(in):: i2
+  real,pointer,dimension(:):: i1
+  i1 => i2
+end