From patchwork Wed Sep 19 21:47:36 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 185234 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 9F7872C0086 for ; Thu, 20 Sep 2012 07:48:20 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1348696100; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=+WQCOqd pD5Ksew8dRyyFyMAPDPU=; b=FYYBvWsF0FIGjHSvX/zzhW0e9wP2JSVDmq+DvFF YIkpOfVgtlnvRb9PfP5tdmQVr8JCDac04HBqS4/cMa98g1AopOmC17kvg0E+JkUb sQl/l0vRehmXZlcwKyVq38WvpBXmpxzbYjldIFHLQRuEjnD0NCw2R9WmH9ytrWEU xXo0= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=hT71M/dhT2G7odJXcogrVshPxEcy616cGL4u02CrqO94g09sKWAFU/bZl9Fj94 Q77fBK/MUQ5ZSsJp4jsk+rTJ36DpOYgDrTdwGJ6QJD0n/5PfA1VO1sl15bE+twwm UPieq0uhrz2DDDoZeorEn1/SSfRyw3sSLQ+VIsyXQRXlk=; Received: (qmail 21925 invoked by alias); 19 Sep 2012 21:48:06 -0000 Received: (qmail 21849 invoked by uid 22791); 19 Sep 2012 21:48:00 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_TM, TW_VP X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 19 Sep 2012 21:47:38 +0000 Received: from [192.168.178.22] (port-92-204-67-8.dynamic.qsc.de [92.204.67.8]) by mx01.qsc.de (Postfix) with ESMTP id 9D8993CFAE; Wed, 19 Sep 2012 23:47:36 +0200 (CEST) Message-ID: <505A3D78.8060703@net-b.de> Date: Wed, 19 Sep 2012 23:47:36 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:15.0) Gecko/20120825 Thunderbird/15.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR54618 fix some INTENT(OUT) issues for CLASS Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch fixes a couple of issues, I run into when working on FINAL subroutines. a) PR54618: (i) For a nonallocatable CLASS(...),INTENT(OUT), gfortran is setting the the _def_init; however, for OPTIONAL this has to be guarded by an is-present check. (ii) For CLASS(...),ALLOCATABLE, INTENT(OUT), gfortran didn't deallocate the dummy argument - nor did it reset the var->_vtab to the declared type. Note: (ii) for polymorphic arrays has still to be implemented, currently, only scalars are handled. There are also some other issues related to OPTIONAL with polymorphic arrays. (See PR.) b) When working on FINAL, I also run into the problem that attr.alloc_comp is set, when there is a pointer component, which only in turn has allocatable components. That lead to an ICE (segfault) with my FINAL patch. c) I also include three coverity patches: (i) resolve.c: "nl->sym" is many times dereferenced (before and after that check), thus it cannot be NULL. (ii) simplify.c: There is an "if (extremum == NULL) ... continue;", hence, one always loops at least once before one reaches that line; but then "last" gets set. Thus, the code is unreachable. (iii) trans-array.c: Here, class_expr is NULL_TREE if the condition is false, but TREE_TYPE(NULL_TREE) won't work. Hence, an assert is better. I intent to do two commits: One for (a) and one for the rest. Build and regtested on x86-64-linux. OK for the trunk? Tobias 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