[flang] lower assumed type actual arguments in call statements

cabreraam · Dec 19, 2023 · dec9ebe · dec9ebe
1 parent 99045b6
commit dec9ebe
Show file tree

Hide file tree

Showing 2 changed files with 57 additions and 5 deletions.
diff --git 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
@@ -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: }