[flang] lower assumed type actual arguments in call statements

[cabreraam]

Taking care of TODOs for assumed type actual arguments in CALL statements.

The approach here borrows from the commits in this pull request that addresses assumed type actual arguments in intrinsic functions.

[llvmbot]

@llvm/pr-subscribers-flang-fir-hlfir

Author: Anthony Cabrera (cabreraam)

Changes

Taking care of TODOs for assumed type actual arguments in CALL statements.

The approach here borrows from the commits in this pull request that addresses assumed type actual arguments in intrinsic functions.

---

Full diff: https://github.com/llvm/llvm-project/pull/75969.diff

2 Files Affected:

• (modified) flang/lib/Lower/ConvertCall.cpp (+18-5)
• (added) flang/test/HLFIR/assumed-type-actual-arguments.f90 (+39)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index fd726c90c07bd0..90421d82d7c48d 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -897,7 +897,8 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
   }
 
   // NULL() actual to procedure pointer dummy
-  if (Fortran::evaluate::IsNullProcedurePointer(expr) &&
+  if (arg.entity->UnwrapExpr() /* TYPE(*) dummy */ &&
+      Fortran::evaluate::IsNullProcedurePointer(expr) &&
       hlfir::isBoxProcAddressType(dummyType)) {
     auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
     auto tempBoxProc{builder.createTemporary(loc, boxTy)};
@@ -1172,8 +1173,6 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
       continue;
     }
     const auto *expr = arg.entity->UnwrapExpr();
-    if (!expr)
-      TODO(loc, "assumed type actual argument");
 
     switch (arg.passBy) {
     case PassBy::Value: {
@@ -2207,8 +2206,22 @@ genProcedureRef(CallContext &callContext) {
        caller.getPassedArguments())
     if (const auto *actual = arg.entity) {
       const auto *expr = actual->UnwrapExpr();
-      if (!expr)
-        TODO(loc, "assumed type actual argument");
+      if (!expr) {
+        // TYPE(*) dummy. They are only allowed as argument of a few intrinsics
+        // that do not take optional arguments: see Fortran 2018 standard C710.
+        const Fortran::evaluate::Symbol *assumedTypeSym =
+            actual->GetAssumedTypeDummy();
+        if (!assumedTypeSym)
+          fir::emitFatalError(
+              loc, "expected assumed-type symbol as actual argument");
+        std::optional<fir::FortranVariableOpInterface> var =
+            callContext.symMap.lookupVariableDefinition(*assumedTypeSym);
+        if (!var)
+          fir::emitFatalError(loc, "assumed-type symbol was not lowered");
+        loweredActuals.push_back(Fortran::lower::PreparedActualArgument{
+            hlfir::Entity{*var}, /*isPresent=*/std::nullopt});
+        continue;
+      }
       if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
               *expr)) {
         if ((arg.passBy !=
diff --git a/flang/test/HLFIR/assumed-type-actual-arguments.f90 b/flang/test/HLFIR/assumed-type-actual-arguments.f90
new file mode 100644
index 00000000000000..716dc2dbb39493
--- /dev/null
+++ b/flang/test/HLFIR/assumed-type-actual-arguments.f90
@@ -0,0 +1,39 @@
+! Test lowering of call statements to HLFIR with assumed types
+! arguments. These are a bit special because semantics do not represent
+! assumed types actual arguments with an evaluate::Expr like for usual
+! arguments.
+! RUN: bbc -emit-hlfir --polymorphic-type -o - %s | FileCheck %s
+
+subroutine test1(x)
+  type(*) :: x
+  interface
+    subroutine fun1(x)
+      type(*) :: x
+    end subroutine
+  end interface
+  call fun1(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest1(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<none> {fir.bindc_name = "x"}) {
+! CHECK:   %[[VAL_0:.*]]:2 = hlfir.declare %[[ARG0]] {uniq_name = "_QFtest1Ex"} : (!fir.ref<none>) -> (!fir.ref<none>, !fir.ref<none>)
+! CHECK:   fir.call @_QPfun1(%[[VAL_0]]#1) fastmath<contract> : (!fir.ref<none>) -> ()
+! CHECK:   return
+! CHECK: }
+
+subroutine test2(x)
+  type(*) :: x
+  interface
+    subroutine fun2(x)
+      type(*) :: x(:)
+    end subroutine
+  end interface
+  call fun2(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest2(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<none> {fir.bindc_name = "x"}) {
+! CHECK:   %[[VAL_0:.*]]:2 = hlfir.declare %[[ARG0]] {uniq_name = "_QFtest2Ex"} : (!fir.ref<none>) -> (!fir.ref<none>, !fir.ref<none>)
+! CHECK:   %[[VAL_1:.*]] = fir.embox %[[VAL_0]]#0 : (!fir.ref<none>) -> !fir.box<none>
+! CHECK:   %[[VAL_2:.*]] = fir.convert %[[VAL_1]] : (!fir.box<none>) -> !fir.box<!fir.array<?xnone>>
+! CHECK:   fir.call @_QPfun2(%[[VAL_2]]) fastmath<contract> : (!fir.box<!fir.array<?xnone>>) -> ()
+! CHECK:   return
+! CHECK: }
\ No newline at end of file

[jeanPerier]

Thank you for working on this!

[jeanPerier]

I think passing *expr to prepareUserCallActualArgument with the assumption that expr will not be used there if it is null is dangerous.

Could you instead try to remove the SomeExpr& argument of prepareUserCallActualArgument and preparePresentUserCallActualArgument, and retrieve the the SomeExpr* expr from arg.entity->UnwrapExpr() here and protect the place where expr is used?

The contiguity test using expr below likely needs to be updated to cover that case.

Other uses of expr can be guarded since assumed type actual argument should not go through those code paths

[jeanPerier]

If you apply my comment above, you can move this to the MutableBox case where it is used with an assert that this is not null (it is not possible to pass an assumed type to a pointer/allocatable).

[jeanPerier]

I think this case is illegal. The argument of an rank one deferred shape must be an array (Fortran 15.5.2.4(16)). Not clear to me why this is not enforced in lib/semantics/check-call.cpp like with none assumed type arguments. This may deserve a separate patch with a semantic fix.

[jeanPerier]

You may want to add some more funny tests.

• passing class(*) to type(*)
• passing optional type(*) deferred shape to optional type(*) assumed size
• passing pointer to optional type(*) deferred shape
• passing rank 2 type(*) deferred shape to rank 1 type(*) assumed size.

[cabreraam]

Addressed in #83851