diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index c961cdbc2df..c63a4a8d38c 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3025,6 +3025,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, } } + if (UNLIMITED_POLY (mold)) + gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L", + &mold->where); + f->ts = mold->ts; if (size == NULL && mold->rank == 0) 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..80dc3426ab0 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); @@ -8419,7 +8432,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { tmp = build_fold_indirect_ref_loc (input_location, argse.expr); if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - source = gfc_class_data_get (tmp); + { + source = gfc_class_data_get (tmp); + class_ref = tmp; + } else { /* Array elements are evaluated as a reference to the data. @@ -8446,9 +8462,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, @@ -8501,6 +8525,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (arg->expr->ts.type == BT_CHARACTER) tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); + else if (arg->expr->ts.type == BT_CLASS) + { + class_ref = TREE_OPERAND (argse.expr, 0); + tmp = gfc_class_vtab_size_get (class_ref); + if (UNLIMITED_POLY (arg->expr)) + tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp); + } else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -8541,15 +8572,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (arg->expr->rank == 0) { - gfc_conv_expr_reference (&argse, arg->expr); + gfc_conv_expr_reference (&argse, mold_expr); mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, argse.expr)); } else { - gfc_init_se (&argse, NULL); argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg->expr); + gfc_conv_expr_descriptor (&argse, mold_expr); mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); } @@ -8560,27 +8590,41 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { /* If this TRANSFER is nested in another TRANSFER, use a type that preserves all bits. */ - if (arg->expr->ts.type == BT_LOGICAL) - mold_type = gfc_get_int_type (arg->expr->ts.kind); + if (mold_expr->ts.type == BT_LOGICAL) + mold_type = gfc_get_int_type (mold_expr->ts.kind); } /* Obtain the destination word length. */ - switch (arg->expr->ts.type) + switch (mold_expr->ts.type) { case BT_CHARACTER: - tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); - mold_type = gfc_get_character_type_len (arg->expr->ts.kind, + tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length); + mold_type = gfc_get_character_type_len (mold_expr->ts.kind, argse.string_length); break; case BT_CLASS: - tmp = gfc_class_vtab_size_get (argse.expr); + if (scalar_mold) + class_ref = argse.expr; + else + class_ref = TREE_OPERAND (argse.expr, 0); + tmp = gfc_class_vtab_size_get (class_ref); + if (UNLIMITED_POLY (arg->expr)) + tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp); break; default: tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); break; } - dest_word_len = gfc_create_var (gfc_array_index_type, NULL); - gfc_add_modify (&se->pre, dest_word_len, tmp); + + /* Do not fix dest_word_len if it is a variable, since the temporary can wind + up being used before the assignment. */ + if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred) + dest_word_len = tmp; + else + { + dest_word_len = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify (&se->pre, dest_word_len, tmp); + } /* Finally convert SIZE, if it is present. */ arg = arg->next; 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..4a2731a34b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_4.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! +! Fix TRANSFER intrinsic for unlimited polymorphic SOURCEs - PR98534 +! Note that unlimited polymorphic MOLD is a TODO. +! +! Contributed by Paul Thomas +! + use, intrinsic :: ISO_FORTRAN_ENV, only: real32 + implicit none + character(*), parameter :: string = "abcdefgh" + character(len=:), allocatable :: string_a(:) + class(*), allocatable :: star + class(*), allocatable :: star_a(:) + character(len=:), allocatable :: chr + character(len=:), allocatable :: chr_a(:) + integer :: sz, sum1, sum2, i + real(real32) :: r = 1.0 + +! Part 1: worked correctly + star = r + 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 /= storage_size (real32)/8) 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 + +! Check that string length and size are correctly handled + string_a = ["abcdefgh", "ijklmnop"] + star_a = string_a; + chr_a = transfer (star_a, chr_a) ! Old string length used for size + if (size(chr_a) .ne. 4) stop 6 + if (len(chr_a) .ne. 5) stop 7 + if (trim (chr_a(3)) .ne. "klmno") stop 8 + if (chr_a(4)(1:1) .ne. "p") stop 9 + + chr_a = transfer (star_a, string_a) ! Use correct string_length for payload + if (size(chr_a) .ne. 2) stop 10 + if (len(chr_a) .ne. 8) stop 11 + if (any (chr_a .ne. string_a)) stop 12 + +! Check that an unlimited polymorphic function result is transferred OK + deallocate (chr_a) + string_a = ['abc', 'def', 'hij'] + chr_a = transfer (foo (string_a), string_a) + if (any (chr_a .ne. string_a)) stop 13 + +! Finally, check that the SIZE gives correct results with unlimited sources. + chr_a = transfer (star_a, chr_a, 4) + if (chr_a (4) .ne. 'jkl') stop 14 + + deallocate (star, chr, star_a, chr_a, string_a) +contains + function foo (arg) result(res) + character(*), intent(in) :: arg(:) + class(*), allocatable :: res(:) + res = arg + end +end