2012-09-19 Tobias Burnus * parse.c (parse_derived): Don't set attr.alloc_comp for pointer components with allocatable subcomps. * resolve.c (resolve_fl_namelist): Remove superfluous NULL check. * simplify.c (simplify_min_max): Remove unreachable code. * trans-array.c (gfc_trans_create_temp_array): Change a condition into an assert. PR fortran/54618 * trans-expr.c (gfc_trans_class_init_assign): Guard re-setting of the vtab by gfc_conv_expr_present. (gfc_conv_procedure_call): Fix INTENT(OUT) handling for allocatable BT_CLASS. 2012-09-19 Tobias Burnus PR fortran/54618 * gfortran.dg/class_array_14.f90: New. diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 5c5d381..f31e309 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2195,7 +2195,8 @@ endType: if (c->attr.allocatable || (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->attr.allocatable) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp)) + || (c->ts.type == BT_DERIVED && !c->attr.pointer + && c->ts.u.derived->attr.alloc_comp)) { allocatable = true; sym->attr.alloc_comp = 1; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f67c07f..0a20540 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12478,7 +12478,7 @@ resolve_fl_namelist (gfc_symbol *sym) continue; nlsym = NULL; - if (nl->sym && nl->sym->name) + if (nl->sym->name) gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym); if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) { diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 1c9dff2..2f96e90 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4106,10 +4106,7 @@ simplify_min_max (gfc_expr *expr, int sign) min_max_choose (arg->expr, extremum->expr, sign); /* Delete the extra constant argument. */ - if (last == NULL) - expr->value.function.actual = arg->next; - else - last->next = arg->next; + last->next = arg->next; arg->next = NULL; gfc_free_actual_arglist (arg); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c350c3b..3e684ee 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1022,8 +1022,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, dynamic type. Generate an eltype and then the class expression. */ if (eltype == NULL_TREE && initial) { - if (POINTER_TYPE_P (TREE_TYPE (initial))) - class_expr = build_fold_indirect_ref_loc (input_location, initial); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); + class_expr = build_fold_indirect_ref_loc (input_location, initial); eltype = TREE_TYPE (class_expr); eltype = gfc_get_element_type (eltype); /* Obtain the structure (class) expression. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 98634c3..177d286 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -621,6 +621,16 @@ gfc_trans_class_init_assign (gfc_code *code) gfc_add_block_to_block (&block, &src.pre); tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); } + + if (code->expr1->symtree->n.sym->attr.optional + || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master) + { + tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -3905,22 +3915,42 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ - if (fsym && fsym->attr.allocatable - && fsym->attr.intent == INTENT_OUT) + if (fsym && fsym->attr.intent == INTENT_OUT + && (fsym->attr.allocatable + || (fsym->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.allocatable))) { stmtblock_t block; + tree ptr; gfc_init_block (&block); - tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, + ptr = parmse.expr; + if (e->ts.type == BT_CLASS) + ptr = gfc_class_data_get (ptr); + + tmp = gfc_deallocate_with_status (ptr, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, NULL, false); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, parmse.expr, + void_type_node, ptr, null_pointer_node); gfc_add_expr_to_block (&block, tmp); + if (fsym->ts.type == BT_CLASS) + { + gfc_symbol *vtab; + gcc_assert (fsym->ts.u.derived == e->ts.u.derived); + vtab = gfc_find_derived_vtab (fsym->ts.u.derived); + tmp = gfc_get_symbol_decl (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + ptr = gfc_class_vptr_get (parmse.expr); + gfc_add_modify (&block, ptr, + fold_convert (TREE_TYPE (ptr), tmp)); + gfc_add_expr_to_block (&block, tmp); + } + if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) --- /dev/null 2012-09-19 07:37:13.203764737 +0200 +++ gcc/gcc/testsuite/gfortran.dg/class_array_14.f90 2012-09-19 23:19:19.000000000 +0200 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/54618 +! +! Check whether default initialization works with INTENT(OUT) +! and ALLOCATABLE and no segfault occurs with OPTIONAL. +! + +subroutine test1() + type typ1 + integer :: i = 6 + end type typ1 + + type(typ1) :: x + + x%i = 77 + call f(x) + if (x%i /= 6) call abort () + call f() +contains + subroutine f(y1) + class(typ1), intent(out), optional :: y1 + end subroutine f +end subroutine test1 + +subroutine test2() + type mytype + end type mytype + type, extends(mytype):: mytype2 + end type mytype2 + + class(mytype), allocatable :: x,y + allocate (mytype2 :: x) + call g(x) + if (allocated (x) .or. .not. same_type_as (x,y)) call abort() + + allocate (mytype2 :: x) + call h(x) + if (allocated (x) .or. .not. same_type_as (x,y)) call abort() + + call h() +contains + subroutine g(y2) + class(mytype), intent(out), allocatable :: y2 + end subroutine g + subroutine h(y3) + class(mytype), optional, intent(out), allocatable :: y3 + end subroutine h +end subroutine test2 + +call test1() +call test2() +end