diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 33794f0a858..8acad60a02b 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -230,7 +230,9 @@ gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; - if (string->ts.u.cl) + if (string->ts.deferred) + f->ts = string->ts; + else if (string->ts.u.cl) f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); @@ -242,7 +244,9 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; - if (string->ts.u.cl) + if (string->ts.deferred) + f->ts = string->ts; + else if (string->ts.u.cl) f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); @@ -3361,7 +3365,7 @@ gfc_resolve_mvbits (gfc_code *c) } -/* Set up the call to RANDOM_INIT. */ +/* Set up the call to RANDOM_INIT. */ void gfc_resolve_random_init (gfc_code *c) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f6ec76acb0b..6e42397c2ea 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -9084,6 +9084,7 @@ static void resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { gfc_expr* target; + bool parentheses = false; gcc_assert (sym->assoc); gcc_assert (sym->attr.flavor == FL_VARIABLE); @@ -9096,6 +9097,16 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; gcc_assert (!sym->assoc->dangling); + if (target->expr_type == EXPR_OP + && target->value.op.op == INTRINSIC_PARENTHESES + && target->value.op.op1->expr_type == EXPR_VARIABLE) + { + sym->assoc->target = gfc_copy_expr (target->value.op.op1); + gfc_free_expr (target); + target = sym->assoc->target; + parentheses = true; + } + if (resolve_target && !gfc_resolve_expr (target)) return; @@ -9177,6 +9188,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) /* See if this is a valid association-to-variable. */ sym->assoc->variable = (target->expr_type == EXPR_VARIABLE + && !parentheses && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ @@ -9191,7 +9203,6 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } - /* We cannot deal with class selectors that need temporaries. */ if (target->ts.type == BT_CLASS && gfc_ref_needs_temporary_p (target->ref)) @@ -10885,11 +10896,6 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) /* Resolve a BLOCK construct statement. */ -static gfc_expr* -get_temp_from_expr (gfc_expr *, gfc_namespace *); -static gfc_code * -build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *, - gfc_component *, gfc_component *, locus); static void resolve_block_construct (gfc_code* code) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 41661b4195e..e1725808033 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -7568,6 +7568,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int full; bool subref_array_target = false; bool deferred_array_component = false; + bool substr = false; gfc_expr *arg, *ss_expr; if (se->want_coarray) @@ -7618,6 +7619,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) && TREE_CODE (desc) == COMPONENT_REF) deferred_array_component = true; + substr = info->ref && info->ref->next + && info->ref->next->type == REF_SUBSTRING; + subref_array_target = (is_subref_array (expr) && (se->direct_byref || expr->ts.type == BT_CHARACTER)); @@ -7659,7 +7663,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target, expr); /* ....and set the span field. */ - tmp = gfc_conv_descriptor_span_get (desc); + if (ss_info->expr->ts.type == BT_CHARACTER) + tmp = gfc_conv_descriptor_span_get (desc); + else + tmp = gfc_get_array_span (desc, expr); gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) @@ -7730,6 +7737,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) need_tmp = 1; if (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl->length && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) get_array_charlen (expr, se); @@ -7915,7 +7923,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the string_length for a character array. */ if (expr->ts.type == BT_CHARACTER) { - if (deferred_array_component) + if (deferred_array_component && !substr) se->string_length = ss_info->string_length; else se->string_length = gfc_get_expr_charlen (expr); @@ -7992,7 +8000,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } /* Set the span field. */ - tmp = gfc_get_array_span (desc, expr); + tmp = NULL_TREE; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + tmp = gfc_conv_descriptor_span_get (desc); + else + tmp = gfc_get_array_span (desc, expr); if (tmp) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); @@ -8766,6 +8778,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, tree add_when_allocated) { tree tmp; + tree eltype; tree size; tree nelems; tree null_cond; @@ -8782,10 +8795,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, null_data = gfc_finish_block (&block); gfc_init_block (&block); + eltype = TREE_TYPE (type); if (str_sz != NULL_TREE) size = str_sz; else - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + size = TYPE_SIZE_UNIT (eltype); if (!no_malloc) { @@ -8812,11 +8826,19 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, else nelems = gfc_index_one_node; + /* If type is not the array type, then it is the element type. */ + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + eltype = gfc_get_element_type (type); + else + eltype = type; + if (str_sz != NULL_TREE) tmp = fold_convert (gfc_array_index_type, str_sz); else tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); + TYPE_SIZE_UNIT (eltype)); + + tmp = gfc_evaluate_now (tmp, &block); size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, nelems, tmp); if (!no_malloc) @@ -9865,6 +9887,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, /* This component cannot have allocatable components, therefore add_when_allocated of duplicate_allocatable () is always NULL. */ + rank = c->as ? c->as->rank : 0; tmp = duplicate_allocatable (dcmp, comp, ctype, rank, false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 25737881ae0..299764b08b2 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1791,6 +1791,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) return decl; } + if (sym->ts.type == BT_UNKNOWN) + gfc_fatal_error ("%s at %C has no default type", sym->name); + if (sym->attr.intrinsic) gfc_internal_error ("intrinsic variable which isn't a procedure"); @@ -7538,6 +7541,7 @@ gfc_generate_function_code (gfc_namespace * ns) } trans_function_start (sym); + gfc_current_locus = sym->declared_at; gfc_init_block (&init); gfc_init_block (&cleanup); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d996d295bd2..f052d6b9440 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2124,6 +2124,7 @@ gfc_get_expr_charlen (gfc_expr *e) { gfc_ref *r; tree length; + tree previous = NULL_TREE; gfc_se se; gcc_assert (e->expr_type == EXPR_VARIABLE @@ -2149,6 +2150,7 @@ gfc_get_expr_charlen (gfc_expr *e) /* Look through the reference chain for component references. */ for (r = e->ref; r; r = r->next) { + previous = length; switch (r->type) { case REF_COMPONENT: @@ -2164,7 +2166,10 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node); length = se.expr; - gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); + if (r->u.ss.end) + gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); + else + se.expr = previous; length = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, se.expr, length); @@ -2554,23 +2559,25 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) expr_flat = gfc_copy_expr (expr); flatten_array_ctors_without_strlen (expr_flat); gfc_resolve_expr (expr_flat); - - gfc_conv_expr (&se, expr_flat); - gfc_add_block_to_block (pblock, &se.pre); - cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); - + if (expr_flat->rank) + gfc_conv_expr_descriptor (&se, expr_flat); + else + gfc_conv_expr (&se, expr_flat); + if (expr_flat->expr_type != EXPR_VARIABLE) + gfc_add_block_to_block (pblock, &se.pre); + se.expr = convert (gfc_charlen_type_node, se.string_length); + gfc_add_block_to_block (pblock, &se.post); gfc_free_expr (expr_flat); - return; } - - /* Convert cl->length. */ - - gcc_assert (cl->length); - - gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); - se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, - se.expr, build_zero_cst (TREE_TYPE (se.expr))); - gfc_add_block_to_block (pblock, &se.pre); + else + { + /* Convert cl->length. */ + gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); + se.expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_charlen_type_node, se.expr, + build_zero_cst (TREE_TYPE (se.expr))); + gfc_add_block_to_block (pblock, &se.pre); + } if (cl->backend_decl && VAR_P (cl->backend_decl)) gfc_add_modify (pblock, cl->backend_decl, se.expr); @@ -7310,10 +7317,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (parmse.string_length && fsym && fsym->ts.deferred) { if (INDIRECT_REF_P (parmse.string_length)) - /* In chains of functions/procedure calls the string_length already - is a pointer to the variable holding the length. Therefore - remove the deref on call. */ - parmse.string_length = TREE_OPERAND (parmse.string_length, 0); + { + /* In chains of functions/procedure calls the string_length already + is a pointer to the variable holding the length. Therefore + remove the deref on call. */ + tmp = parmse.string_length; + parmse.string_length = TREE_OPERAND (parmse.string_length, 0); + } else { tmp = parmse.string_length; @@ -7321,6 +7331,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_evaluate_now (parmse.string_length, &se->pre); parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp); } + + if (e && e->expr_type == EXPR_VARIABLE + && fsym->attr.allocatable + && e->ts.u.cl->backend_decl + && VAR_P (e->ts.u.cl->backend_decl)) + { + if (INDIRECT_REF_P (tmp)) + tmp = TREE_OPERAND (tmp, 0); + gfc_add_modify (&se->post, e->ts.u.cl->backend_decl, + fold_convert (gfc_charlen_type_node, tmp)); + } } /* Character strings are passed as two parameters, a length and a @@ -8584,6 +8605,20 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); gfc_add_modify (&block, dest, se.expr); + if (cm->ts.type == BT_CHARACTER + && gfc_deferred_strlen (cm, &tmp)) + { + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (tmp), + TREE_OPERAND (dest, 0), + tmp, NULL_TREE); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), + se.string_length)); + cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node, + "slen"); + gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length); + } /* Deal with arrays of derived types with allocatable components. */ if (gfc_bt_struct (cm->ts.type) @@ -8607,11 +8642,16 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, tmp, expr->rank, NULL_TREE); } } + else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) + tmp = gfc_duplicate_allocatable (dest, se.expr, + gfc_typenode_for_spec (&cm->ts), + cm->as->rank, NULL_TREE); else tmp = gfc_duplicate_allocatable (dest, se.expr, TREE_TYPE(cm->backend_decl), cm->as->rank, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se.post); diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index baeea955d35..9b54d2f0d31 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -2622,10 +2622,10 @@ gfc_trans_transfer (gfc_code * code) if (expr->ts.type != BT_CLASS && expr->expr_type == EXPR_VARIABLE - && gfc_expr_attr (expr).pointer) + && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred) + || gfc_expr_attr (expr).pointer)) goto scalarize; - if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL diff --git a/gcc/testsuite/gfortran.dg/associate_47.f90 b/gcc/testsuite/gfortran.dg/associate_47.f90 index 085c6f38338..d8a50c6091c 100644 --- a/gcc/testsuite/gfortran.dg/associate_47.f90 +++ b/gcc/testsuite/gfortran.dg/associate_47.f90 @@ -39,10 +39,9 @@ program p end associate if (x%d(1) .ne. 'zqrtyd') stop 5 -! Substrings of arrays still do not work correctly. call foo ('lmnopqrst','ghijklmno') associate (y => x%d(:)(2:4)) -! if (any (y .ne. ['mno','hij'])) stop 6 + if (any (y .ne. ['mno','hij'])) stop 6 end associate call foo ('abcdef','ghijkl') diff --git a/gcc/testsuite/gfortran.dg/associate_51.f90 b/gcc/testsuite/gfortran.dg/associate_51.f90 index e6f2e4fafa3..2e5218c78cf 100644 --- a/gcc/testsuite/gfortran.dg/associate_51.f90 +++ b/gcc/testsuite/gfortran.dg/associate_51.f90 @@ -51,7 +51,7 @@ recursive subroutine s end recursive subroutine s2 - associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" } + associate (y => (s2)) ! { dg-error "is a procedure name" } end associate end diff --git a/gcc/testsuite/gfortran.dg/associate_60.f90 b/gcc/testsuite/gfortran.dg/associate_60.f90 new file mode 100644 index 00000000000..d804d62f400 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_60.f90 @@ -0,0 +1,138 @@ +! { dg-do run } +! +! Tests fixes for various pr87477 dependencies +! +! Contributed by Gerhard Steinmetz except for pr102106: +! which was contributed by Brad Richardson +! +program associate_60 + implicit none + character(20) :: buffer + + call pr102106 + call pr100948 + call pr85686 + call pr88247 + call pr91941 + call pr92779 + call pr93339 + call pr93813 + +contains + + subroutine pr102106 + type :: sub_class_t + integer :: i + end type + type :: with_polymorphic_component_t + class(sub_class_t), allocatable :: sub_obj_ + end type + associate(obj => with_polymorphic_component_t(sub_class_t(42))) + if (obj%sub_obj_%i .ne. 42) stop 1 + end associate + end + + subroutine pr100948 + type t + character(:), allocatable :: c(:) + end type + type(t), allocatable :: x +! +! Valid test in comment 1 +! + x = t(['ab','cd']) + associate (y => x%c(:)) + if (any (y .ne. x%c)) stop 2 + if (any (y .ne. ['ab','cd'])) stop 3 + end associate + deallocate (x) +! +! Allocation with source was found to only copy over one of the array elements +! + allocate (x, source = t(['ef','gh'])) + associate (y => x%c(:)) + if (any (y .ne. x%c)) stop 4 + if (any (y .ne. ['ef','gh'])) stop 5 + end associate + deallocate (x) + end + + subroutine pr85686 + call s85686([" g'day "," bye!! "]) + if (trim (buffer) .ne. " a g'day a bye!!") stop 6 + end + + subroutine s85686(x) + character(*) :: x(:) + associate (y => 'a'//x) + write (buffer, *) y ! Used to segfault at the write statement. + end associate + end + + subroutine pr88247 + type t + character(:), dimension(:), allocatable :: d + end type t + type(t), allocatable :: x + character(5) :: buffer(3) + allocate (x, source = t (['ab','cd'])) ! Didn't work + write(buffer(1), *) x%d(2:1:-1) ! Was found to be broken + write(buffer(2), *) [x%d(2:1:-1)] ! Was OK + associate (y => [x%d(2:1:-1)]) + write(buffer(3), *) y ! Bug in comment 7 + end associate + if (any (buffer .ne. " cdab")) stop 7 + end + + subroutine pr91941 + character(:), allocatable :: x(:), z(:) + x = [' abc', ' xyz'] + z = adjustl(x) + associate (y => adjustl(x)) ! Wrong character length was passed + if (any(y .ne. ['abc ', 'xyz '])) stop 8 + end associate + end + + subroutine pr92779 + character(3) :: a = 'abc' + associate (y => spread(trim(a),1,2) // 'd') + if (any (y .ne. ['abcd','abcd'])) stop 9 + end associate + end + + subroutine pr93339 + type t + character(:), allocatable :: a(:) + end type + type(t) :: x + x = t(["abc "]) ! Didn't assign anything +! allocate (x%a(1), source = 'abc') ! Worked OK + associate (y => x%a) + if (any (y .ne. 'abc ')) stop 10 + associate (z => x%a) + if (any (y .ne. z)) stop 11 + end associate + end associate + end + + subroutine pr93813 + type t + end type + type, extends(t) :: t2 + end type + class(t), allocatable :: x + integer :: i = 0 + allocate (t :: x) + associate (y => (x)) ! The parentheses triggered an ICE in select type + select type (y) + type is (t2) + stop 12 + type is (t) + i = 42 + class default + stop 13 + end select + end associate + if (i .ne. 42) stop 14 + end +end diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 index 58f4ce84a2c..560e5351323 100644 --- a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 @@ -8,8 +8,9 @@ type(t), allocatable :: b(:) ! { dg-note {'b' declared here} {} { target *-*-* } .-1 } !$acc update host(b(::2)) -! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 } -! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 } +! { dg-warning {'b\.span' is used uninitialized} {} { target *-*-* } .-1 } +! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-2 } +! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-3 } !$acc update host(b(1)%A(::3,::4)) end diff --git a/gcc/testsuite/gfortran.dg/pr105205.f90 b/gcc/testsuite/gfortran.dg/pr105205.f90 new file mode 100644 index 00000000000..0b6ada6e50f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105205.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Contributed by Rich Townsend +! +program alloc_char_type + implicit none + integer, parameter :: start = 1, finish = 4 + character(3) :: check(4) + type mytype + character(:), allocatable :: c(:) + end type mytype + type(mytype) :: a + type(mytype) :: b + integer :: i + a%c = ['foo','bar','biz','buz'] + check = ['foo','bar','biz','buz'] + b = a + do i = 1, size(b%c) + if (b%c(i) .ne. check(i)) stop 1 + end do + if (any (a%c .ne. check)) stop 2 + if (any (a%c(start:finish) .ne. check)) stop 3 + deallocate (a%c) + deallocate (b%c) +end diff --git a/gcc/testsuite/gfortran.dg/pr106918.f90 b/gcc/testsuite/gfortran.dg/pr106918.f90 new file mode 100644 index 00000000000..25f72b36079 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr106918.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! +! Contributed by Lionel Guez +! + character(len = :), allocatable:: attr_name(:) + character(6) :: buffer + type coord_def + character(len = :), allocatable:: attr_name(:) + end type coord_def + type(coord_def) coordinates + attr_name = ["units"] + write (buffer, *) attr_name + if (buffer .ne. " units") stop 1 + coordinates = coord_def(attr_name) + write (buffer, *) coordinates%attr_name + if (buffer .ne. " units") stop 2 + deallocate (attr_name) + deallocate (coordinates%attr_name) +end diff --git a/gcc/testsuite/gfortran.dg/pr98408.f90 b/gcc/testsuite/gfortran.dg/pr98408.f90 new file mode 100644 index 00000000000..4ec1a08fe02 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr98408.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! +! Contributed by Thomas Koenig +! +program main + character (len=:), allocatable :: a(:) + allocate (character(len=10) :: a(5)) + if (sizeof(a) .ne. 50) stop 1 + deallocate (a) +end program main