From patchwork Thu Jan 26 20:28:56 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 138033 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 33F81B6F98 for ; Fri, 27 Jan 2012 07:29:19 +1100 (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=1328214559; 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=FEUnYAW 0bLMBuTOPXvnwlmyPO+0=; b=c6TQ9MGIaWyk5E8xw/DUVHS7Lse60mmuytBvpF6 V1MzhJYYOR9UFrHrpA7srW1YqK9P6xCsbcYMk8LsZlh3Wlgs9vkvon1DgjjSeh8x PPqgeUHU0fhE5lAsOCyuEB1OD/u6hNaoUCqHCOtsgOmiPHUlVRT5nPcGp5fMzBAn KwaY= 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=FXImeQqpa+xSS9ua9a2DhXOSuZmaR6AQeZFOjatOk/HWINpvM17OkfuUBEi4DQ fvqf1PmhLGcnEWtKBWjXGCzDYu/pFdfBDEyi6+J9fUdtX+tHGMK49swgBdzEv4eH Ur7ri5dM2xBH47bwbvqK8s+Dbr9Gj1mArJPfPmWFNOJXA=; Received: (qmail 11674 invoked by alias); 26 Jan 2012 20:29:14 -0000 Received: (qmail 11657 invoked by uid 22791); 26 Jan 2012 20:29:13 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE 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; Thu, 26 Jan 2012 20:28:58 +0000 Received: from [192.168.178.22] (port-92-204-93-204.dynamic.qsc.de [92.204.93.204]) by mx01.qsc.de (Postfix) with ESMTP id D6C423D016; Thu, 26 Jan 2012 21:28:56 +0100 (CET) Message-ID: <4F21B788.4030209@net-b.de> Date: Thu, 26 Jan 2012 21:28:56 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:9.0) Gecko/20111220 Thunderbird/9.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR51970/51977 MOVE_ALLOC fixes 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 expressions involving polymorphic arrays and, thus, MOVE_ALLOC. I have also two minor fixes (cf. trans-decl.c). Build and regtested on x86-64-linux. OK for the trunk? Tobias 2012-01-26 Tobias Burnus PR fortran/51970 PR fortran/51977 * primary.c (gfc_match_varspec. gfc_match_rvalue): Set handle array spec for BT_CLASS. * expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym) * frontend-passes.c (create_var): Ditto. * resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto. * trans-decl.c (gfc_trans_deferred_vars): Use class_pointer instead of attr.pointer. (gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS. * trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert. * trans-stmt.c (trans_associate_var): Ask for the descriptor. 2012-01-26 Tobias Burnus PR fortran/51970 PR fortran/51977 * gfortran.dg/move_alloc_13.f90: New. Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (Revision 183575) +++ gcc/fortran/primary.c (Arbeitskopie) @@ -1868,18 +1868,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.codimension))) { + gfc_array_spec *as; + + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character variables. We'll leave the decision till resolve time. */ - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, - equiv_flag, - sym->ts.type == BT_CLASS && CLASS_DATA (sym) - ? (CLASS_DATA (sym)->as - ? CLASS_DATA (sym)->as->corank : 0) - : (sym->as ? sym->as->corank : 0)); + if (equiv_flag) + as = NULL; + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + + m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, + as ? as->corank : 0); if (m != MATCH_YES) return m; @@ -2893,7 +2899,10 @@ gfc_match_rvalue (gfc_expr **result) e->value.function.actual = actual_arglist; e->where = gfc_current_locus; - if (sym->as != NULL) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as) + e->rank = CLASS_DATA (sym)->as->rank; + else if (sym->as != NULL) e->rank = sym->as->rank; if (!sym->attr.function Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 183575) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -1175,6 +1175,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_ gfc_se se; gfc_init_se (&se, NULL); + se.descriptor_only = 1; gfc_conv_expr (&se, e); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 183575) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -3805,9 +3805,12 @@ gfc_get_variable_expr (gfc_symtree *var) e->symtree = var; e->ts = var->n.sym->ts; - if (var->n.sym->as != NULL) + if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) + || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) + && CLASS_DATA (var->n.sym)->as)) { - e->rank = var->n.sym->as->rank; + e->rank = var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; @@ -3836,7 +3839,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) lval->ref->u.ar.type = AR_FULL; lval->ref->u.ar.dimen = lval->rank; lval->ref->u.ar.where = sym->declared_at; - lval->ref->u.ar.as = sym->as; + lval->ref->u.ar.as = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as : sym->as; } return lval; Index: gcc/fortran/frontend-passes.c =================================================================== --- gcc/fortran/frontend-passes.c (Revision 183575) +++ gcc/fortran/frontend-passes.c (Arbeitskopie) @@ -328,7 +328,8 @@ create_var (gfc_expr * e) result->ref->type = REF_ARRAY; result->ref->u.ar.type = AR_FULL; result->ref->u.ar.where = e->where; - result->ref->u.ar.as = symbol->as; + result->ref->u.ar.as = symbol->ts.type == BT_CLASS + ? CLASS_DATA (symbol)->as : symbol->as; if (gfc_option.warn_array_temp) gfc_warning ("Creating array temporary at %L", &(e->where)); } Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 183575) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -1740,13 +1740,17 @@ resolve_actual_arglist (gfc_actual_arglist *arg, p got_variable: e->expr_type = EXPR_VARIABLE; e->ts = sym->ts; - if (sym->as != NULL) + if ((sym->as != NULL && sym->ts.type != BT_CLASS) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as)) { - e->rank = sym->as->rank; + e->rank = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as->rank : sym->as->rank; e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; - e->ref->u.ar.as = sym->as; + e->ref->u.ar.as = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as : sym->as; } /* Expressions are assigned a default ts.type of BT_PROCEDURE in @@ -7930,13 +7934,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_t sym->attr.asynchronous = tsym->attr.asynchronous; sym->attr.volatile_ = tsym->attr.volatile_; - if (tsym->ts.type == BT_CLASS) - sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer; - else - sym->attr.target = tsym->attr.target || tsym->attr.pointer; - - if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS) - target->rank = sym->as ? sym->as->rank : 0; + sym->attr.target = tsym->attr.target + || gfc_expr_attr (target).pointer; } /* Get type if this was not already set. Note that it can be @@ -7951,10 +7950,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_t && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ - if (sym->attr.dimension - && (target->ts.type == BT_CLASS - ? !CLASS_DATA (target)->attr.dimension - : target->rank == 0)) + if (sym->attr.dimension && target->rank == 0) { gfc_error ("Associate-name '%s' at %L is used as array", sym->name, &sym->declared_at); Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (Revision 183575) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -3687,7 +3687,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf } else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.pointer)) + && CLASS_DATA (sym)->attr.class_pointer)) continue; else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable @@ -5341,7 +5341,8 @@ gfc_generate_function_code (gfc_namespace * ns) null_pointer_node)); else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable - && sym->attr.dimension == 0 && sym->result == sym) + && CLASS_DATA (sym)->attr.dimension == 0 + && sym->result == sym) { tmp = CLASS_DATA (sym)->backend_decl; tmp = fold_build3_loc (input_location, COMPONENT_REF, Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 183575) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -7237,10 +7237,11 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + gcc_assert (from_expr->ts.type != BT_CLASS + || to_expr->ts.type == BT_CLASS); + if (from_expr->rank == 0) { - gcc_assert (from_expr->ts.type != BT_CLASS - || to_expr->ts.type == BT_CLASS); if (from_expr->ts.type != BT_CLASS) from_expr2 = from_expr; else Index: gcc/testsuite/gfortran.dg/move_alloc_13.f90 =================================================================== --- gcc/testsuite/gfortran.dg/move_alloc_13.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/move_alloc_13.f90 (Arbeitskopie) @@ -0,0 +1,39 @@ +! { dg-do run} +! +! PR fortran/51970 +! PR fortran/51977 +! +type t +end type t +type, extends(t) :: t2 + integer :: a +end type t2 + +class(t), allocatable :: y(:), z(:) + +allocate(y(2), source=[t2(2), t2(3)]) +call func2(y,z) + +select type(z) + type is(t2) + if (any (z(:)%a /= [2, 3])) call abort() + class default + call abort() +end select + +contains + function func(x) + class (t), allocatable :: x(:), func(:) + call move_alloc (x, func) + end function + + function func1(x) + class (t), allocatable :: x(:), func1(:) + call move_alloc (func1, x) + end function + + subroutine func2(x, y) + class (t), allocatable :: x(:), y(:) + call move_alloc (x, y) + end subroutine +end