[flang] Fix issues with STORAGE_SIZE and characters

flang/include/flang/Evaluate/call.h

@@ -268,7 +268,17 @@ template <typename A> class FunctionRef : public ProcedureRef {
   FunctionRef(ProcedureDesignator &&p, ActualArguments &&a)
       : ProcedureRef{std::move(p), std::move(a)} {}
 
-  std::optional<DynamicType> GetType() const { return proc_.GetType(); }
+  std::optional<DynamicType> GetType() const {
+    if (auto type{proc_.GetType()}) {
+      // TODO: Non constant explicit length parameters of PDTs result should
+      // likely be dropped too. This is not as easy as for characters since some
+      // long lived DerivedTypeSpec pointer would need to be created here. It is
+      // not clear if this is causing any issue so far since the storage size of
+      // PDTs is independent of length parameters.
+      return type->DropNonConstantCharacterLength();
+    }
+    return std::nullopt;
+  }
 };
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_CALL_H_

flang/include/flang/Evaluate/type.h

@@ -231,6 +231,12 @@ class DynamicType {
     }
   }
 
+  // Get a copy of this dynamic type where charLengthParamValue_ is reset if it
+  // is not a constant expression. This avoids propagating symbol references in
+  // scopes where they do not belong. Returns the type unmodified if it is not
+  // a character or if the length is not explicit.
+  DynamicType DropNonConstantCharacterLength() const;
+
 private:
   // Special kind codes are used to distinguish the following Fortran types.
   enum SpecialKind {

flang/lib/Evaluate/type.cpp

@@ -836,4 +836,15 @@ bool IsCUDAIntrinsicType(const DynamicType &type) {
   }
 }
 
+DynamicType DynamicType::DropNonConstantCharacterLength() const {
+  if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) {
+    if (std::optional<std::int64_t> len{knownLength()}) {
+      return DynamicType(kind_, *len);
+    } else {
+      return DynamicType(category_, kind_);
+    }
+  }
+  return *this;
+}
+
 } // namespace Fortran::evaluate

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -5284,11 +5284,8 @@ IntrinsicLibrary::genStorageSize(mlir::Type resultType,
         builder.getKindMap().getIntegerBitsize(fir::toInt(constOp)));
   }
 
-  if (args[0].getBoxOf<fir::PolymorphicValue>()) {
-    box = builder.createBox(loc, args[0], /*isPolymorphic=*/true);
-  } else if (box.getType().isa<fir::ReferenceType>()) {
-    box = builder.create<fir::LoadOp>(loc, box);
-  }
+  box = builder.createBox(loc, args[0],
+                          /*isPolymorphic=*/args[0].isPolymorphic());
   mlir::Value eleSize = builder.create<fir::BoxEleSizeOp>(loc, kindTy, box);
   mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8);
   return builder.create<mlir::arith::MulIOp>(loc, eleSize, c8);

flang/test/Evaluate/rewrite06.f90

@@ -0,0 +1,33 @@
+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+subroutine test_storage_size(n)
+  interface
+    function return_char(l)
+      integer :: l
+      character(l) :: return_char
+    end function
+  end interface
+  integer n
+  !CHECK: PRINT *, storage_size(return_char(n))
+  print*, storage_size(return_char(n))
+  !CHECK: PRINT *, sizeof(return_char(n))
+  print*, sizeof(return_char(n))
+end subroutine
+
+module pdts
+  type t(l)
+    integer, len :: l
+    character(l) :: c
+  end type
+contains
+  function return_pdt(n)
+    type(t(n)) :: return_pdt
+  end function
+  subroutine test(k)
+    ! NOTE: flang design for length parametrized derived type
+    ! is to use allocatables for the automatic components. Hence,
+    ! their size is independent from the length parameters and is
+    ! a compile time constant.
+    !CHECK: PRINT *, 192_4
+    print *, storage_size(return_pdt(k))
+  end subroutine
+end module

flang/test/Lower/Intrinsics/storage_size-2.f90

@@ -0,0 +1,30 @@
+! Test storage_size with characters
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+
+! check-label: func.func @_QPtest_storage_size
+subroutine test_storage_size(n)
+  interface
+    function return_char(l)
+      integer :: l
+      character(l) :: return_char
+    end function
+  end interface
+  integer n
+  print*, storage_size(return_char(n))
+! CHECK: %[[val_16:.*]] = fir.call @_QPreturn_char(%[[res_addr:[^,]*]], %[[res_len:[^,]*]], {{.*}})
+! CHECK: %[[res:.*]]:2 = hlfir.declare %[[res_addr]] typeparams %[[res_len]]
+! CHECK: %[[val_18:.*]] = fir.embox %[[res]]#1 typeparams %[[res_len]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+! CHECK: %[[val_19:.*]] = fir.box_elesize %[[val_18]] : (!fir.box<!fir.char<1,?>>) -> i32
+! CHECK: %[[val_20:.*]] = arith.constant 8 : i32
+! CHECK: %[[val_21:.*]] = arith.muli %[[val_19]], %[[val_20]] : i32
+! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[val_21]])
+end subroutine
+
+function return_char(l)
+  integer :: l
+  character(l) :: return_char
+end function
+
+  call test_storage_size(42)
+  print *, 42*8
+end

flang/test/Semantics/call05.f90

@@ -155,6 +155,15 @@ subroutine smb(b)
     integer, allocatable, intent(in) :: b(:)
   end
 
+  function return_deferred_length_ptr()
+    character(len=:), pointer :: return_deferred_length_ptr
+  end function
+
+  function return_explicit_length_ptr(n)
+    integer :: n
+    character(len=n), pointer :: return_explicit_length_ptr
+  end function
+
   subroutine test()
 
     !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
@@ -167,6 +176,16 @@ subroutine test()
 
     call smp2(p1) ! ok
 
+    call smp(return_deferred_length_ptr()) ! ok
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call smp2(return_deferred_length_ptr())
+
+    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
+    call smp(return_explicit_length_ptr(10))
+
+    call smp2(return_explicit_length_ptr(10)) ! ok
+
     !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
     call sma(t2(:))