From patchwork Mon May 4 14:53:15 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 467625 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 79720140157 for ; Tue, 5 May 2015 00:53:47 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=sfGEft5q; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=tWvcfEMBjS6Pes56sEMIrfVH6YhP+P7tJha72UenK7JmdDbAl8e/B 4mYi6GibwAnh8pR7tOjGRbAtMDez6Jt5meoyFqgD5sAJIro+7hcA6Bcnsdb5MrdT rh9GF73nYFb8awPLqeQpjF2PmB8xLnmReP1iwQE0UKiSFqVjkbYFqQ= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=UVA0M45jBr7dDngyzso+r6YRj18=; b=sfGEft5qG476gtduDoXx aqPyb9jA9tLXfM8qDcpVjVAKuhHZU2qKE2u8Un8V2rMpkdPPi4B3gN4WorY0uMgj tHYxVVS17ZQ8xQYna6tj9b0cBfohJXIUK8JixLht0exkkkdAhtJY82MCNZ++xt+a xmTxA0TpPJaREGFem/UmcOg= Received: (qmail 50462 invoked by alias); 4 May 2015 14:53:24 -0000 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 Received: (qmail 50368 invoked by uid 89); 4 May 2015 14:53:23 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.6 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.22) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 04 May 2015 14:53:20 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx103) with ESMTPSA (Nemesis) id 0M4o41-1ZC3kX34Bx-00yw9d; Mon, 04 May 2015 16:53:17 +0200 Date: Mon, 4 May 2015 16:53:15 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [Patch, fortran, 64674, v1] [OOP] ICE in ASSOCIATE with class array Message-ID: <20150504165315.477b7f77@gmx.de> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, I like to present here a first patch for using class arrays in associate. Upto now gfortran crashed, when a class array-section/element was selected in an associate. This patch fixes this now for class array sections as well as for single elements. The story of the patch is told quite shortly: - parse.c::parse_associate() needs to gather more information about what the target is like. Previously the target's rank and array_spec was not computed, which disallowed the use of further array refs in the associate body: associate (vec => class_matrix(2:3, 2)) vec(1) = ... ! <- Unclassifiable statement, because no array_spec was attached to vec. This is fixed by the second hunk of the patch. - The third hunk in primary.c prevents setting the dimension attribute on a class object's symbol. - The hunks in resolve.c take care about adding dummy full array_refs and in resolve_assoc_var correct the class type, when the target expression's rank is 0. Previously the symbol would have an array valued type, when the target's base type was array valued. But for a scalar target this needed some polishing. - Additionally a test was added. Bootstraps and regtests ok on x86_64-linux-gnu/f21. Ok for trunk? Note, this patch was diffed from a trunk with my older patches for PR65548, v3 https://gcc.gnu.org/ml/fortran/2015-04/msg00123.html and PR44672, v5 https://gcc.gnu.org/ml/fortran/2015-04/msg00124.html applied. Regards, Andre diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 2c7c554..05b8d3d 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3960,6 +3960,8 @@ parse_associate (void) for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol* sym; + gfc_ref *ref; + gfc_array_ref *array_ref; if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) gcc_unreachable (); @@ -3976,6 +3978,84 @@ parse_associate (void) for parsing component references on the associate-name in case of association to a derived-type. */ sym->ts = a->target->ts; + + /* Check if the target expression is array valued. This can not always + be done by looking at target.rank, because that might not have been + set yet. Therefore traverse the chain of refs, looking for the last + array ref and evaluate that. */ + array_ref = NULL; + for (ref = a->target->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + array_ref = &ref->u.ar; + if (array_ref || a->target->rank) + { + gfc_array_spec *as; + int dim, rank = 0; + if (array_ref) + { + /* Count the dimension, that have a non-scalar extend. */ + for (dim = 0; dim < array_ref->dimen; ++dim) + if (array_ref->dimen_type[dim] != DIMEN_ELEMENT + && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN + && array_ref->end[dim] == NULL + && array_ref->start[dim] != NULL)) + ++rank; + } + else + rank = a->target->rank; + /* When the rank is greater than zero then sym will be an array. */ + if (sym->ts.type == BT_CLASS) + { + if ((!CLASS_DATA (sym)->as && rank != 0) + || (CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->rank != rank)) + { + /* Don't just (re-)set the attr and as in the sym.ts, + because this modifies the target's attr and as. Copy the + data and do a build_class_symbol. */ + symbol_attribute attr = CLASS_DATA (a->target)->attr; + int corank = gfc_get_corank (a->target); + gfc_typespec type; + + if (rank || corank) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = corank; + attr.dimension = rank ? 1 : 0; + attr.codimension = corank ? 1 : 0; + } + else + { + as = NULL; + attr.dimension = attr.codimension = 0; + } + attr.class_ok = 0; + type = CLASS_DATA (sym)->ts; + if (!gfc_build_class_symbol (&type, + &attr, &as)) + gcc_unreachable (); + sym->ts = type; + sym->ts.type = BT_CLASS; + sym->attr.class_ok = 1; + } + else + sym->attr.class_ok = 1; + } + else if ((!sym->as && rank != 0) + || (sym->as && sym->as->rank != rank)) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = gfc_get_corank (a->target); + sym->as = as; + sym->attr.dimension = 1; + if (as->corank) + sym->attr.codimension = 1; + } + } } accept_statement (ST_ASSOCIATE); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e9ced7e..46810de 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1860,7 +1860,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (sym->assoc && gfc_peek_ascii_char () == '(' && !(sym->assoc->dangling && sym->assoc->st && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->attr.dimension == 0)) + && sym->assoc->st->n.sym->attr.dimension == 0) + && sym->ts.type != BT_CLASS) sym->attr.dimension = 1; if ((equiv_flag && gfc_peek_ascii_char () == '(') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 41026af..2ac4689 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4973,6 +4973,30 @@ resolve_variable (gfc_expr *e) return false; } + /* For variables that are used in an associate (target => object) where + the object's basetype is array valued while the target is scalar, + the ts' type of the component refs is still array valued, which + can't be translated that way. */ + if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS + && sym->assoc->target->ts.type == BT_CLASS + && CLASS_DATA (sym->assoc->target)->as) + { + gfc_ref *ref = e->ref; + while (ref) + { + switch (ref->type) + { + case REF_COMPONENT: + ref->u.c.sym = sym->ts.u.derived; + /* Stop the loop. */ + ref = NULL; + break; + default: + ref = ref->next; + break; + } + } + } /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. @@ -4998,6 +5022,49 @@ resolve_variable (gfc_expr *e) e->ref->u.ar.dimen = 0; } + /* Like above, but for class types, where the checking whether an array + ref is present is more complicated. Furthermore make sure not to add + the full array ref to _vptr or _len refs. */ + if (sym->assoc && sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.dimension + && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) + { + gfc_ref *ref, *newref; + + newref = gfc_get_ref (); + newref->type = REF_ARRAY; + newref->u.ar.type = AR_FULL; + newref->u.ar.dimen = 0; + /* Because this is an associate var and the first ref either is a ref to + the _data component or not, no traversal of the ref chain is + needed. The array ref needs to be inserted after the _data ref, + or when that is not present, which may happend for polymorphic + types, then at the first position. */ + ref = e->ref; + if (!ref) + e->ref = newref; + else if (ref->type == REF_COMPONENT + && strcmp ("_data", ref->u.c.component->name) == 0) + { + if (!ref->next || ref->next->type != REF_ARRAY) + { + newref->next = ref->next; + ref->next = newref; + } + else + /* Array ref present already. */ + gfc_free_ref_list (newref); + } + else if (ref->type == REF_ARRAY) + /* Array ref present already. */ + gfc_free_ref_list (newref); + else + { + newref->next = ref; + e->ref = newref; + } + } + if (e->ref && !resolve_ref (e)) return false; @@ -8061,6 +8128,9 @@ gfc_type_is_extensible (gfc_symbol *sym) } +static void +resolve_types (gfc_namespace *ns); + /* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ @@ -8123,6 +8193,7 @@ 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)) @@ -8132,22 +8203,81 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } - if (target->ts.type != BT_CLASS && target->rank > 0) - sym->attr.dimension = 1; - else if (target->ts.type == BT_CLASS) + if (target->ts.type == BT_CLASS) gfc_fix_class_refs (target); - /* The associate-name will have a correct type by now. Make absolutely - sure that it has not picked up a dimension attribute. */ - if (sym->ts.type == BT_CLASS) - sym->attr.dimension = 0; - - if (sym->attr.dimension) + if (target->rank != 0) { - sym->as = gfc_get_array_spec (); - sym->as->rank = target->rank; - sym->as->type = AS_DEFERRED; - sym->as->corank = gfc_get_corank (target); + gfc_array_spec *as; + if (sym->ts.type != BT_CLASS && !sym->as) + { + as = gfc_get_array_spec (); + as->rank = target->rank; + as->type = AS_DEFERRED; + as->corank = gfc_get_corank (target); + sym->attr.dimension = 1; + if (as->corank != 0) + sym->attr.codimension = 1; + sym->as = as; + } + } + else + { + /* target's rank is 0, but the type of the sym is still array valued, + which has to be corrected. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + { + gfc_array_spec *as; + symbol_attribute attr; + /* The associated variable's type is still the array type + correct this now. */ + gfc_typespec *ts = &target->ts; + gfc_ref *ref; + gfc_component *c; + for (ref = target->ref; ref != NULL; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + ts = &ref->u.c.component->ts; + break; + case REF_ARRAY: + if (ts->type == BT_CLASS) + ts = &ts->u.derived->components->ts; + break; + default: + break; + } + } + /* Create a scalar instance of the current class type. Because the + rank of a class array goes into its name, the type has to be + rebuild. The alternative of (re-)setting just the attributes + and as in the current type, destroys the type also in other + places. */ + as = NULL; + sym->ts = *ts; + sym->ts.type = BT_CLASS; + attr = CLASS_DATA (sym)->attr; + attr.class_ok = 0; + attr.associate_var = 1; + attr.dimension = attr.codimension = 0; + attr.class_pointer = 1; + if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) + gcc_unreachable (); + /* Make sure the _vptr is set. */ + c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); + CLASS_DATA (sym)->attr.pointer = 1; + CLASS_DATA (sym)->attr.class_pointer = 1; + gfc_set_sym_referenced (sym->ts.u.derived); + gfc_commit_symbol (sym->ts.u.derived); + /* _vptr now has the _vtab in it, change it to the _vtype. */ + if (c->ts.u.derived->attr.vtab) + c->ts.u.derived = c->ts.u.derived->ts.u.derived; + c->ts.u.derived->ns->types_resolved = 0; + resolve_types (c->ts.u.derived->ns); + } } /* Mark this as an associate variable. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 19869c3..4bbd685 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2536,7 +2536,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && !sym->attr.result && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.codimension) - && !CLASS_DATA (sym)->attr.allocatable + && (sym->assoc + || !CLASS_DATA (sym)->attr.allocatable) && !CLASS_DATA (sym)->attr.class_pointer) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); diff --git a/gcc/testsuite/gfortran.dg/associate_18.f08 b/gcc/testsuite/gfortran.dg/associate_18.f08 new file mode 100644 index 0000000..fdcc645 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_18.f08 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Contributed by Antony Lewis +! Andre Vehreschild +! Check that associating array-sections/scalars is working +! with class arrays. +! + +program associate_18 + Type T + integer :: map = 1 + end Type T + + class(T), allocatable :: av(:) + class(T), allocatable :: am(:,:) + class(T), pointer :: pv(:) + class(T), pointer :: pm(:,:) + + integer :: iv(5) = 17 + integer :: im(4,5) = 23 + + allocate(av(2)) + associate(i => av(1)) + i%map = 2 + end associate + if (any (av%map /= [2,1])) call abort() + deallocate(av) + + allocate(am(3,4)) + associate(pam => am(2:3, 2:3)) + pam%map = 7 + pam(1,2)%map = 8 + end associate + if (any (reshape(am%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) call abort() + deallocate(am) + + allocate(pv(2)) + associate(i => pv(1)) + i%map = 2 + end associate + if (any (pv%map /= [2,1])) call abort() + deallocate(pv) + + allocate(pm(3,4)) + associate(ppm => pm(2:3, 2:3)) + ppm%map = 7 + ppm(1,2)%map = 8 + end associate + if (any (reshape(pm%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) call abort() + deallocate(pm) + + associate(i => iv(1)) + i = 7 + end associate + if (any (iv /= [7, 17, 17, 17, 17])) call abort() + + associate(pam => im(2:3, 2:3)) + pam = 9 + pam(1,2) = 10 + end associate + if (any (reshape(im, [20]) /= [23,23,23,23, 23,9,9,23, & + 23,10,9,23, 23,23,23,23, 23,23,23,23])) call abort() +end program +