[flang] Support external procedure passed as actual argument with implicit character...

As Fortran 2018 15.5.2.9 point 2, the actual argument and dummy argument
have the same type and type parameters and an external function with
assumed character length may be associated with a dummy argument with
explicit character length. As Fortran 2018 15.5.2.9 point 7, if an
external procedure is used as an actual argument, it can be explicitly
declared to have the EXTERNAL attribute. This supports the external
procedure passed as actual argument with implicit character type, either
explicit character length or assumed character length.

Reviewed By: Jean Perier, klausler

Differential Revision: https://reviews.llvm.org/D124345

diff --git a/flang/include/flang/Optimizer/Builder/Character.h b/flang/include/flang/Optimizer/Builder/Character.h
index e64a704..8b95262 100644 (file)
--- a/flang/include/flang/Optimizer/Builder/Character.h
+++ b/flang/include/flang/Optimizer/Builder/Character.h
@@ -204,8 +204,8 @@ private:
 mlir::Type getCharacterProcedureTupleType(mlir::Type funcPointerType);
 
 /// Create a tuple<addr, len> given \p addr and \p len as well as the tuple
-/// type \p argTy. \p addr must be any function address, and \p len must be
-/// any integer. Converts will be inserted if needed if \addr and \p len
+/// type \p argTy. \p addr must be any function address, and \p len may be any
+/// integer or nullptr. Converts will be inserted if needed if \addr and \p len
 /// types are not the same as the one inside the tuple type \p tupleType.
 mlir::Value createCharacterProcedureTuple(fir::FirOpBuilder &builder,
                                           mlir::Location loc,

diff --git a/flang/lib/Optimizer/Builder/Character.cpp b/flang/lib/Optimizer/Builder/Character.cpp
index 4a90a69..c025270 100644 (file)
--- a/flang/lib/Optimizer/Builder/Character.cpp
+++ b/flang/lib/Optimizer/Builder/Character.cpp
@@ -718,7 +718,10 @@ mlir::Value fir::factory::createCharacterProcedureTuple(
     mlir::Value addr, mlir::Value len) {
   mlir::TupleType tupleType = argTy.cast<mlir::TupleType>();
   addr = builder.createConvert(loc, tupleType.getType(0), addr);
-  len = builder.createConvert(loc, tupleType.getType(1), len);
+  if (len)
+    len = builder.createConvert(loc, tupleType.getType(1), len);
+  else
+    len = builder.create<fir::UndefOp>(loc, tupleType.getType(1));
   mlir::Value tuple = builder.create<fir::UndefOp>(loc, tupleType);
   tuple = builder.create<fir::InsertValueOp>(
       loc, tupleType, tuple, addr,

diff --git a/flang/test/Lower/ext-proc-as-actual-argument-1.f90 b/flang/test/Lower/ext-proc-as-actual-argument-1.f90
new file mode 100644 (file)
index 0000000..e121a82
--- /dev/null
+++ b/flang/test/Lower/ext-proc-as-actual-argument-1.f90
@@ -0,0 +1,31 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test external procedure as actual argument with the implicit character type.
+
+! CHECK-LABEL: func @_QQmain
+! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPext_func) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+! CHECK:  %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_2:.*]] = fir.undefined i64
+! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QFPsub(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+! CHECK:  return
+
+! CHECK-LABEL: func @_QPext_func(
+! CEHCK: %[[ARG_0:.*]]: !fir.ref<!fir.char<1,?>>, %[[ARG_1:.*]]: index) -> !fir.boxchar<1> {
+program m
+  external :: ext_func
+  call sub(ext_func)
+
+contains
+  subroutine sub(arg)
+    character(20), external :: arg
+    print *, arg()
+  end
+end
+
+function ext_func() result(res)
+  character(*) res
+  res = "hello world"
+end

diff --git a/flang/test/Lower/ext-proc-as-actual-argument-2.f90 b/flang/test/Lower/ext-proc-as-actual-argument-2.f90
new file mode 100644 (file)
index 0000000..8c04e86
--- /dev/null
+++ b/flang/test/Lower/ext-proc-as-actual-argument-2.f90
@@ -0,0 +1,31 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test external procedure as actual argument with the implicit character type.
+
+! CHECK-LABEL: func @_QQmain
+! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPext_func) : (!fir.ref<!fir.char<1,20>>, index) -> !fir.boxchar<1>
+! CHECK:  %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,20>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_2:.*]] = fir.undefined i64
+! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QFPsub(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+! CHECK:  return
+
+! CHECK-LABEL: func @_QPext_func(
+! CEHCK: %[[ARG_0:.*]]: !fir.ref<!fir.char<1,20>>, %[[ARG_1:.*]]: index) -> !fir.boxchar<1> {
+program m
+  external :: ext_func
+  call sub(ext_func)
+
+contains
+  subroutine sub(arg)
+    character(20), external :: arg
+    print *, arg()
+  end
+end
+
+function ext_func() result(res)
+  character(20) res
+  res = "hello world"
+end