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..023258c1b43 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,9 +2559,12 @@ 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); + 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); cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); gfc_free_expr (expr_flat); @@ -8584,6 +8592,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 +8629,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