diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index bc8eb419cff..4590aa6edb4 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size) size = gfc_evaluate_now (size, block); tmp = gfc_evaluate_now (fold_convert (type , tmp), block); } + else + tmp = fold_convert (type , tmp); tmp2 = fold_build2_loc (input_location, MULT_EXPR, type, size, tmp); tmp = fold_build2_loc (input_location, GT_EXPR, @@ -11994,15 +11996,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, /* Take into account _len of unlimited polymorphic entities. TODO: handle class(*) allocatable function results on rhs. */ - if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE) + if (UNLIMITED_POLY (rhs)) { - tree len = trans_get_upoly_len (block, rhs); + tree len; + if (rhs->expr_type == EXPR_VARIABLE) + len = trans_get_upoly_len (block, rhs); + else + len = gfc_class_len_get (tmp); len = fold_build2_loc (input_location, MAX_EXPR, size_type_node, fold_convert (size_type_node, len), size_one_node); size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size), size, fold_convert (TREE_TYPE (size), len)); } + else if (rhs->ts.type == BT_CHARACTER && rse->string_length) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, size, + rse->string_length); + tmp = lse->expr; class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 83041183fcb..e18e4d1e183 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -8250,7 +8250,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) { gfc_expr *arg; gfc_se argse; - tree type, result_type, tmp; + tree type, result_type, tmp, class_decl = NULL; + gfc_symbol *sym; + bool unlimited = false; arg = expr->value.function.actual->expr; @@ -8261,10 +8263,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) { if (arg->ts.type == BT_CLASS) { + unlimited = UNLIMITED_POLY (arg); gfc_add_vptr_component (arg); gfc_add_size_component (arg); gfc_conv_expr (&argse, arg); tmp = fold_convert (result_type, argse.expr); + class_decl = gfc_get_class_from_expr (argse.expr); goto done; } @@ -8276,14 +8280,20 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) { argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg); + sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL; if (arg->ts.type == BT_CLASS) { - if (arg->rank > 0) + unlimited = UNLIMITED_POLY (arg); + if (TREE_CODE (argse.expr) == COMPONENT_REF) + tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + else if (arg->rank > 0 && sym + && DECL_LANG_SPECIFIC (sym->backend_decl)) tmp = gfc_class_vtab_size_get ( - GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)); else - tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + gcc_unreachable (); tmp = fold_convert (result_type, tmp); + class_decl = gfc_get_class_from_expr (argse.expr); goto done; } type = gfc_get_element_type (TREE_TYPE (argse.expr)); @@ -8297,6 +8307,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) tmp = fold_convert (result_type, tmp); done: + if (unlimited && class_decl) + tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp); + se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp, build_int_cst (result_type, BITS_PER_UNIT)); gfc_add_block_to_block (&se->pre, &argse.pre); @@ -8446,9 +8459,17 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) break; case BT_CLASS: if (class_ref != NULL_TREE) - tmp = gfc_class_vtab_size_get (class_ref); + { + tmp = gfc_class_vtab_size_get (class_ref); + if (UNLIMITED_POLY (source_expr)) + tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp); + } else - tmp = gfc_class_vtab_size_get (argse.expr); + { + tmp = gfc_class_vtab_size_get (argse.expr); + if (UNLIMITED_POLY (source_expr)) + tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp); + } break; default: source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, diff --git a/gcc/testsuite/gfortran.dg/storage_size_7.f90 b/gcc/testsuite/gfortran.dg/storage_size_7.f90 new file mode 100644 index 00000000000..e32ca1b6a0e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/storage_size_7.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027. +! Contributed by Steve Kargl +! and José Rui Faustino de Sousa +program p + use, intrinsic :: ISO_FORTRAN_ENV, only: int64 + type t + integer i + end type + type s + class(t), allocatable :: c(:) + end type + integer :: rslt, class_rslt + integer(kind=int64), target :: tgt + class(t), allocatable, target :: t_alloc(:) + class(s), allocatable, target :: s_alloc(:) + character(:), allocatable, target :: chr(:) + class(*), pointer :: ptr_s, ptr_a(:) + + allocate (t_alloc(2), source=t(1)) + rslt = storage_size(t_alloc(1)) ! Scalar arg - the original testcase + if (rslt .ne. 32) stop 1 + + rslt = storage_size(t_alloc) ! Array arg + if (rslt .ne. 32) stop 2 + + call pr100027 + + allocate (s_alloc(2), source=s([t(1), t(2)])) +! This, of course, is processor dependent: gfortran gives 576, NAG 448 +! and Intel 1216. + class_rslt = storage_size(s_alloc) ! Type with a class component + ptr_s => s_alloc(2) +! However, the unlimited polymorphic result should be the same + if (storage_size (ptr_s) .ne. class_rslt) stop 3 + ptr_a => s_alloc + if (storage_size (ptr_a) .ne. class_rslt) stop 4 + + rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg + if (rslt .ne. 32) stop 5 + + rslt = storage_size(s_alloc(1)%c) ! Scalar component of array arg + if (rslt .ne. 32) stop 6 + + ptr_s => tgt + rslt = storage_size (ptr_s) ! INTEGER(8) target + if (rslt .ne. 64) stop 7 + + allocate (chr(2), source = ["abcde", "fghij"]) + ptr_s => chr(2) + rslt = storage_size (ptr_s) ! CHARACTER(5) scalar + if (rslt .ne. 40) stop 8 + + ptr_a => chr + rslt = storage_size (ptr_a) ! CHARACTER(5) array + if (rslt .ne. 40) stop 9 + + deallocate (t_alloc, s_alloc, chr) ! For valgrind check + +contains + +! Original testcase from José Rui Faustino de Sousa + subroutine pr100027 + implicit none + + integer, parameter :: n = 11 + + type :: foo_t + end type foo_t + + type, extends(foo_t) :: bar_t + end type bar_t + + class(*), pointer :: apu(:) + class(foo_t), pointer :: apf(:) + class(bar_t), pointer :: apb(:) + type(bar_t), target :: atb(n) + + integer :: m + + apu => atb + m = storage_size(apu) + if (m .ne. 0) stop 10 + apf => atb + m = storage_size(apf) + if (m .ne. 0) stop 11 + apb => atb + m = storage_size(apb) + if (m .ne. 0) stop 12 + end +end program p diff --git a/gcc/testsuite/gfortran.dg/transfer_class_4.f90 b/gcc/testsuite/gfortran.dg/transfer_class_4.f90 new file mode 100644 index 00000000000..4babd1f41d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_4.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Fix TRANSFER intrinsic for unlimited polymorphic arguments - PR98534 +! Contributed by Paul Thomas + character(*), parameter :: string = "abcdefgh" + class(*), allocatable :: star + class(*), allocatable :: star_a(:) + character(len=:), allocatable :: chr + character(len=5), allocatable :: chr_a(:) + integer :: sz, sum1, sum2 + +! Part 1: worked correctly + star = 1.0 + sz = storage_size (star)/8 + allocate (character(len=sz) :: chr) + chr = transfer (star, chr) + sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + chr = transfer(1.0, chr) + sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + + if (sz /= kind (1.0)) stop 1 + if (sum1 /= sum2) stop 2 + + deallocate (star) ! The automatic reallocation causes invalid writes + ! and memory leaks. Even with this deallocation + ! The invalid writes still occur. + deallocate (chr) + +! Part 2: Got everything wrong because '_len' field of unlimited polymorphic +! expressions was not used. + star = string + sz = storage_size (star)/8 + if (sz /= len (string)) stop 3 ! storage_size failed + + sz = len (string) ! Ignore previous error in storage_size + allocate (character(len=sz) :: chr) + chr = transfer (star, chr) + sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + chr = transfer(string, chr) + sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + if (sum1 /= sum2) stop 4 ! transfer failed + +! Check that arrays are OK for transfer + star_a = ['abcde','fghij'] + allocate (character (len = 5) :: chr_a(2)) + chr_a = transfer (star_a, chr_a) + if (any (chr_a .ne. ['abcde','fghij'])) stop 5 + deallocate (star, chr, star_a, chr_a) +end