From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 48501 invoked by alias); 19 May 2015 10:27:11 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 48480 invoked by uid 89); 19 May 2015 10:27:10 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.3 required=5.0 tests=AWL,BAYES_50,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.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Tue, 19 May 2015 10:27:06 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0MOTRh-1Yr5pg38T7-005tB1; Tue, 19 May 2015 12:27:01 +0200 Date: Tue, 19 May 2015 10:29:00 -0000 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec Message-ID: <20150519122602.028db8d5@vepi2> In-Reply-To: <20150430161742.1273247f@gmx.de> References: <20150330194749.18e21169@vepi2> <20150401151540.4979eb07@vepi2> <20150402110330.45ad027b@vepi2> <20150423144511.5e7b12c5@gmx.de> <20150429172358.03f42041@gmx.de> <20150430161742.1273247f@gmx.de> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_//WDRtrGEA9m_6orsV9eaypr" X-UI-Out-Filterresults: notjunk:1; X-SW-Source: 2015-05/txt/msg01678.txt.bz2 --MP_//WDRtrGEA9m_6orsV9eaypr Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 3023 Hi all, update based on latest 65548 (v5) patch and current trunk. Description and issue addressed unchanged (see cite below). Bootstrapped and regtested on x86_64-linux-gnu/f21. Any volunteers to review? The initial version dates back to March 30. 2015. Not a single comment so far! - Andre On Thu, 30 Apr 2015 16:17:42 +0200 Andre Vehreschild wrote: > Hi all, > > and also for this bug, I like to present an updated patch. It was brought to > my attention, that the previous patch did not fix statements like: > > allocate(m, source=[(I, I=1, n)]) > > where n is a variable and > > type p > class(*), allocatable :: m(:,:) > end type > real mat(2,3) > type(P) :: o > allocate(o%m, source=mat) > > The new version of the patch fixes those issue now also and furthermore > addresses some issues (most probably not all) where the rank of the > source=-variable and the rank of the array to allocate differ. For example, > when one is do: > > real v(:) > allocate(v, source= arr(1,2:3)) > > where arr has a rank of 2 and only the source=-expression a rank of one, which > is then compatible with v. Nevertheless did this need addressing, when setting > up the descriptor of the v and during data copy. > > Bootstrap ok on x86_64-linux-gnu/f21. > Regtests with one regression in gfortran.dg/alloc_comp_constructor_1.f90, > which is addressed in the patch for pr58586, whose final version is in > preparation. > > Ok for trunk in combination with 58586 once both are reviewed? > > Regards, > Andre > > > On Wed, 29 Apr 2015 17:23:58 +0200 > Andre Vehreschild wrote: > > > Hi all, > > > > this is the fourth version of the patch, adapting to the current state of > > trunk. This patch is based on my patch for 65584 version 2 and needs that > > patch applied beforehand to apply cleanly. The patch for 65548 is available > > from: > > > > https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html > > > > Scope: > > > > Allow allocate of arrays w/o having to give an array-spec as specified in > > F2008:C633. An example is: > > > > integer, dimension(:) :: arr > > allocate(arr, source = [1,2,3]) > > > > Solution: > > > > While resolving an allocate, the objects to allocate are analyzed whether > > they carry an array-spec, if not the array-spec of the source=-expression is > > transferred. Unfortunately some source=-expressions are not easy to handle > > and have to be assigned to a temporary variable first. Only with the > > temporary variable the gfc_trans_allocate() is then able to compute the > > array descriptor correctly and allocate with correct array bounds. > > > > Side notes: > > > > This patch creates a regression in alloc_comp_constructor_1.f90 where two > > free()'s are gone missing. This will be fixed by the patch for pr58586 and > > therefore not repeated here. > > > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > > > > Ok for trunk? > > > > Regards, > > Andre > > > > -- Andre Vehreschild * Email: vehre ad gmx dot de --MP_//WDRtrGEA9m_6orsV9eaypr Content-Type: application/octet-stream; name=pr44672_6.clog Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=pr44672_6.clog Content-length: 2168 Z2NjL3Rlc3RzdWl0ZS9DaGFuZ2VMb2c6CgoyMDE1LTA1LTE5ICBBbmRyZSBW ZWhyZXNjaGlsZCAgPHZlaHJlQGdteC5kZT4KCglQUiBmb3J0cmFuLzQ0Njcy CglQUiBmb3J0cmFuLzQ1NDQwCglQUiBmb3J0cmFuLzU3MzA3CgkqIGdmb3J0 cmFuLmRnL2FsbG9jYXRlX3dpdGhfc291cmNlXzMuZjkwOiBFbmhhbmNlZCB0 bwoJY2hlY2sgaW1wbGVtZW50YXRpb24gb2YgRjIwMDg6QzYzMy4KCSogZ2Zv cnRyYW4uZGcvYWxsb2NhdGVfd2l0aF9zb3VyY2VfNi5mMDg6IE5ldyB0ZXN0 LgoKZ2NjL2ZvcnRyYW4vQ2hhbmdlTG9nOgoKMjAxNS0wNS0xOSAgQW5kcmUg VmVocmVzY2hpbGQgIDx2ZWhyZUBnbXguZGU+CgoJUFIgZm9ydHJhbi80NDY3 MgoJUFIgZm9ydHJhbi80NTQ0MAoJUFIgZm9ydHJhbi81NzMwNwoJKiBnZm9y dHJhbi5oOiBFeHRlbmQgZ2ZjX2NvZGUuZXh0LmFsbG9jIHRvIGNhcnJ5IGEK CWZsYWcgaW5kaWNhdGluZyB0aGF0IHRoZSBhcnJheSBzcGVjaWZpY2F0aW9u IGhhcyB0byBiZQoJdGFrZW4gZnJvbSBleHByMy4KCSogcmVzb2x2ZS5jIChy ZXNvbHZlX2FsbG9jYXRlX2V4cHIpOiBBZGQgRjIwMDggbm90aWZ5CglhbmQg ZmxhZyBpbmRpY2F0aW5nIHNvdXJjZSBkcml2ZW4gYXJyYXkgc3BlYy4KCShy ZXNvbHZlX2FsbG9jYXRlX2RlYWxsb2NhdGUpOiBDaGVjayBmb3Igc291cmNl IGRyaXZlbgoJYXJyYXkgc3BlYywgd2hlbiBhcnJheSB0byBhbGxvY2F0ZSBo YXMgbm8gZXhwbGljaXQKCWFycmF5IHNwZWMuIEdlbmVyYXRlIHRlbXBvcmF5 IHZhcmlhYmxlIGFzc2lnbm1lbnQgdG8KCWFsbG93IHNvdXJjZS1leHByZXNz aW9ucyB3aXRob3V0IGV4cGxpY2l0IGFycmF5CglzcGVjaWZpY2F0aW9uLgoJ KiB0cmFucy1hcnJheS5jIChnZmNfYXJyYXlfaW5pdF9zaXplKTogR2V0IGxv d2VyIGFuZAoJdXBwZXIgYm91bmQgZnJvbSBhIHRyZWUgYXJyYXkgZGVzY3Jp cHRvci4KCShyZXRyaWV2ZV9sYXN0X3JlZik6IEV4dHJhY3RlZCBmcm9tIGdm Y19hcnJheV9hbGxvY2F0ZSgpLgoJKGdmY19hcnJheV9hbGxvY2F0ZSk6IEVu YWJsZSBhbGxvY2F0ZShhcnJheSwgc291cmNlPSAKCWFycmF5X2V4cHJlc3Np b24pIGFzIHNwZWNpZmllZCBieSBGMjAwODpDNjMzLgoJKGdmY19jb252X2V4 cHJfZGVzY3JpcHRvcik6IEFkZCBjbGFzcyB0cmVlIGV4cHJlc3Npb24KCWlu dG8gdGhlIHNhdmVkIGRlc2NyaXB0b3IgZm9yIGNsYXNzIGFycmF5cy4KCSog dHJhbnMtYXJyYXkuaDogQWRkIHRlbXBvcmFyeSBhcnJheSBkZXNjcmlwdG9y IHRvCglnZmNfYXJyYXlfYWxsb2NhdGUgKCkuCgkqIHRyYW5zLWV4cHIuYyAo Z2ZjX2NvbnZfcHJvY2VkdXJlX2NhbGwpOiBQcmV2ZW50IGFycmF5Cgljb25z dHJ1Y3RvcnMgZm9yIGFsbG9jYXRhYmxlIGNvbXBvbmVudHMgdG8gZ2VuZXJh dGUKCWRlYWxsb2NhdGUgY29kZS4KCSogdHJhbnMtc3RtdC5jIChnZmNfdHJh bnNfYWxsb2NhdGUpOiBHZXQgZXhwcjMgYXJyYXkKCWRlc2NyaXB0b3IgZm9y IHRlbXBvcmFyeSBhcnJheXMgdG8gYWxsb3cgYWxsb2NhdGUoYXJyYXksCglz b3VyY2UgPSBhcnJheV9leHByZXNzaW9uKSBmb3IgYXJyYXkgd2l0aG91dCBh cnJheQoJc3BlY2lmaWNhdGlvbi4KCg== --MP_//WDRtrGEA9m_6orsV9eaypr Content-Type: text/x-patch Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=pr44672_6.patch Content-length: 28734 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index aaa4e89..a7d862b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2396,6 +2396,9 @@ typedef struct gfc_code { gfc_typespec ts; gfc_alloc *list; + /* Take the array specification from expr3 to allocate arrays + without an explicit array specification. */ + unsigned arr_spec_from_expr3:1; } alloc; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fbf260f..6678138 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) have a trailing array reference that gives the size of the array. */ static bool -resolve_allocate_expr (gfc_expr *e, gfc_code *code) +resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) { int i, pointer, allocatable, dimension, is_abstract; int codimension; @@ -7103,13 +7103,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL || (dimension && ref2->u.ar.dimen == 0)) { - gfc_error ("Array specification required in ALLOCATE statement " - "at %L", &e->where); - goto failure; + /* F08:C633. */ + if (code->expr3) + { + if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " + "in ALLOCATE statement at %L", &e->where)) + goto failure; + *array_alloc_wo_spec = true; + } + else + { + gfc_error ("Array specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } } /* Make sure that the array section reference makes sense in the - context of an ALLOCATE specification. */ + context of an ALLOCATE specification. */ ar = &ref2->u.ar; @@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) for (i = 0; i < ar->dimen; i++) { - if (ref2->u.ar.type == AR_ELEMENT) + if (ar->type == AR_ELEMENT || ar->type == AR_FULL) goto check_symbols; switch (ar->dimen_type[i]) @@ -7201,12 +7212,18 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { gfc_expr *stat, *errmsg, *pe, *qe; gfc_alloc *a, *p, *q; + /* When this flag is set already, then this allocate has already been + resolved. Doing so again, would result in an endless loop. */ + if (code->ext.alloc.arr_spec_from_expr3) + return; + stat = code->expr1; errmsg = code->expr2; @@ -7375,8 +7392,109 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (strcmp (fcn, "ALLOCATE") == 0) { + bool arr_alloc_wo_spec = false; for (a = code->ext.alloc.list; a; a = a->next) - resolve_allocate_expr (a->expr, code); + resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); + + if (arr_alloc_wo_spec && code->expr3) + { + /* Mark the allocate to have to take the array specification + from the expr3. */ + code->ext.alloc.arr_spec_from_expr3 = 1; + + if (code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_FUNCTION) + { + /* The trans stage can not cope with expr3->expr_type + being EXPR_ARRAY or EXPR_FUNCTION, therefore create a + temporary variable and assign expr3 to it, substituting + the variable in expr3. */ + char name[25]; + static unsigned int alloc_sym_count = 0; + gfc_symbol *temp_var_sym; + gfc_expr *temp_var; + gfc_code *ass, *old_alloc; + gfc_namespace *ns = + code->ext.alloc.list->expr->symtree->n.sym->ns; + gfc_array_spec *as; + int dim; + mpz_t dim_size; + + /* The name of the new variable. */ + sprintf (name, "alloc_arr_init.%d", alloc_sym_count++); + gfc_get_symbol (name, ns, &temp_var_sym); + temp_var_sym->attr.artificial = 1; + temp_var_sym->attr.flavor = FL_VARIABLE; + temp_var_sym->ts = code->expr3->ts; + /* Build an EXPR_VARIABLE node. */ + temp_var = gfc_get_expr (); + temp_var->expr_type = EXPR_VARIABLE; + temp_var->symtree = gfc_find_symtree (ns->sym_root, name); + temp_var->ts = code->expr3->ts; + temp_var->where = code->expr3->where; + + /* Now to the most important: Set the array specification + correctly. */ + as = gfc_get_array_spec (); + temp_var->rank = as->rank = code->expr3->rank; + if (code->expr3->expr_type == EXPR_ARRAY) + { + /* For EXPR_ARRAY the as can be deduced from the shape. */ + as->type = AS_EXPLICIT; + for (dim = 0; dim < as->rank; ++dim) + { + if (!gfc_array_dimen_size (code->expr3, dim, &dim_size)) + { + /* When the array dimensions can not be determined at + compile time, use a deferred type array. */ + as->type = AS_DEFERRED; + while (dim >= 0) + { + as->lower[dim] = as->upper[dim] = NULL; + --dim; + } + temp_var_sym->attr.allocatable = 1; + break; + } + as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind, + &code->expr3->where, 1); + as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind, + &code->expr3->where, + mpz_get_si (dim_size)); + } + } + else if (code->expr3->expr_type == EXPR_FUNCTION) + { + /* For functions this is far more complicated. */ + as->type = AS_DEFERRED; + temp_var_sym->attr.allocatable = 1; + } + else + gcc_unreachable (); + + temp_var_sym->as = as; + temp_var_sym->attr.dimension = 1; + gfc_add_full_array_ref (temp_var, as); + + ass = gfc_get_code (EXEC_ASSIGN); + ass->expr1 = gfc_copy_expr (temp_var); + ass->expr2 = code->expr3; + ass->loc = code->expr3->where; + + gfc_resolve_code (ass, ns); + /* Now add the new code before this ones. */ + old_alloc = gfc_get_code (EXEC_ALLOCATE); + *old_alloc = *code; + *code = *ass; + code->next = old_alloc; + + /* Do not gfc_free_expr (temp_var), because it is inserted + without copy into expr3. */ + old_alloc->expr3 = temp_var; + gfc_set_sym_referenced (temp_var_sym); + gfc_commit_symbol (temp_var_sym); + } + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8267f6a..2e9582d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5009,7 +5009,8 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3, + tree expr3_desc) { tree type; tree tmp; @@ -5024,7 +5025,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tree var; stmtblock_t thenblock; stmtblock_t elseblock; - gfc_expr *ubound; + gfc_expr *ubound = NULL; gfc_se se; int n; @@ -5039,6 +5040,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, or_expr = boolean_false_node; + /* When expr3_desc is set, use its rank, because we want to allocate an + array with the array_spec coming from source=. */ + if (expr3_desc != NULL_TREE) + rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc)); + for (n = 0; n < rank; n++) { tree conv_lbound; @@ -5048,24 +5054,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, lower == NULL => lbound = 1, ubound = upper[n] upper[n] = NULL => lbound = 1, ubound = lower[n] upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ - ubound = upper[n]; /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) - se.expr = gfc_index_one_node; + if (expr3_desc != NULL_TREE) + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]); else { - gcc_assert (lower[n]); - if (ubound) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } + ubound = upper[n]; + if (lower == NULL) + se.expr = gfc_index_one_node; else { - se.expr = gfc_index_one_node; - ubound = lower[n]; + gcc_assert (lower[n]); + if (ubound) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } } } gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, @@ -5080,10 +5091,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set upper bound. */ gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - + if (expr3_desc != NULL_TREE) + se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, gfc_rank_cst[n]); + else + { + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; @@ -5253,6 +5268,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, } +/* Retrieve the last ref from the chain. This routine is specific to + gfc_array_allocate ()'s needs. */ + +bool +retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) +{ + gfc_ref *ref, *prev_ref; + + ref = *ref_in; + /* Prevent warnings for uninitialized variables. */ + prev_ref = *prev_ref_in; + while (ref && ref->next != NULL) + { + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); + prev_ref = ref; + ref = ref->next; + } + + if (ref == NULL || ref->type != REF_ARRAY) + return false; + + *ref_in = ref; + *prev_ref_in = prev_ref; + return true; +} + /* Initializes the descriptor and generates a call to _gfor_allocate. Does the work for an ALLOCATE statement. */ /*GCC ARRAYS*/ @@ -5260,7 +5302,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3) + tree *nelems, gfc_expr *expr3, tree e3_arr_desc) { tree tmp; tree pointer; @@ -5278,21 +5320,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable, coarray, dimension; + bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false; ref = expr->ref; /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + + if (ref->u.ar.type == AR_FULL && expr3 != NULL) { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT - || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); - prev_ref = ref; - ref = ref->next; - } + /* F08:C633: Array shape from expr3. */ + ref = expr3->ref; - if (ref == NULL || ref->type != REF_ARRAY) - return false; + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + alloc_w_e3_arr_spec = true; + } if (!prev_ref) { @@ -5328,7 +5373,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, break; case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT); + gcc_assert (ref->u.ar.as->type == AS_EXPLICIT + || alloc_w_e3_arr_spec); lower = ref->u.ar.as->lower; upper = ref->u.ar.as->upper; @@ -5342,10 +5388,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, overflow = integer_zero_node; gfc_init_block (&set_descriptor_block); - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank + : ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3); + expr3_elem_size, nelems, expr3, e3_arr_desc); if (dimension) { @@ -7084,6 +7131,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) desc = parm; } + /* For class arrays add the class tree into the saved descriptor to + enable getting of _vptr and the like. */ + if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) + && IS_CLASS_ARRAY (expr->symtree->n.sym) + && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl)) + { + gfc_allocate_lang_decl (desc); + GFC_DECL_SAVED_DESCRIPTOR (desc) = + GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl); + } if (!se->direct_byref || se->byref_noassign) { /* Get a pointer to the new descriptor. */ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2155b58..6e5378f 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *); + tree, tree *, gfc_expr *, tree); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9be8a42..b02b255 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5328,7 +5328,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) && e->ts.u.derived->attr.alloc_comp && !(e->symtree && e->symtree->n.sym->attr.pointer) - && (e->expr_type != EXPR_VARIABLE && !e->rank)) + && e->expr_type != EXPR_VARIABLE && !e->rank + && e->expr_type != EXPR_STRUCTURE) { int parm_rank; tmp = build_fold_indirect_ref_loc (input_location, diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6d565ae..3528626 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code) element size, i.e. _vptr%size, is stored in expr3_esize. Any of the trees may be the NULL_TREE indicating that this is not available for expr3's type. */ - tree expr3, expr3_vptr, expr3_len, expr3_esize; + tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5117,6 +5117,7 @@ gfc_trans_allocate (gfc_code * code) stat = tmp = memsz = al_vptr = al_len = NULL_TREE; expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; label_errmsg = label_finish = errmsg = errlen = NULL_TREE; + expr3_desc = NULL_TREE; gfc_init_block (&block); gfc_init_block (&post); @@ -5174,21 +5175,31 @@ gfc_trans_allocate (gfc_code * code) { if (!code->expr3->mold || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) + || vtab_needed + || code->ext.alloc.arr_spec_from_expr3) { /* Convert expr3 to a tree. */ gfc_init_se (&se, NULL); - /* For all "simple" expression just get the descriptor or the - reference, respectively, depending on the rank of the expr. */ - if (code->expr3->rank != 0) - gfc_conv_expr_descriptor (&se, code->expr3); - else - gfc_conv_expr_reference (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; + if (code->ext.alloc.arr_spec_from_expr3) + { + gfc_conv_expr_descriptor (&se, code->expr3); + expr3_desc = se.expr; + } else - expr3_tmp = se.expr; - expr3_len = se.string_length; + { + /* For all "simple" expression just get the descriptor + or the reference, respectively, depending on the + rank of the expr. */ + if (code->expr3->rank != 0) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (!code->expr3->mold) + expr3 = se.expr; + else + expr3_tmp = se.expr; + expr3_len = se.string_length; + } gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); } @@ -5215,7 +5226,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); /* Prevent aliasing, i.e., se.expr may be already a - variable declaration. */ + variable declaration. */ if (!VAR_P (se.expr)) { tree var; @@ -5233,6 +5244,10 @@ gfc_trans_allocate (gfc_code * code) expr3 = tmp; else expr3_tmp = tmp; + /* Insert this check for security reasons. A array descriptor + for a complicated expr3 is very unlikely. */ + if (code->ext.alloc.arr_spec_from_expr3) + gcc_unreachable (); /* When he length of a char array is easily available here, fix it for future use. */ if (se.string_length) @@ -5487,7 +5502,8 @@ gfc_trans_allocate (gfc_code * code) else tmp = expr3_esize; if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, code->expr3)) + label_finish, tmp, &nelems, + code->expr3, expr3_desc)) { /* A scalar or derived type. First compute the size to allocate. @@ -5690,17 +5706,26 @@ gfc_trans_allocate (gfc_code * code) { /* Initialization via SOURCE block (or static default initializer). Classes need some special handling, so catch them first. */ - if (expr3 != NULL_TREE - && ((POINTER_TYPE_P (TREE_TYPE (expr3)) - && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))) + if ((expr3_desc != NULL_TREE + || (expr3 != NULL_TREE + && ((POINTER_TYPE_P (TREE_TYPE (expr3)) + && TREE_CODE (expr3) != POINTER_PLUS_EXPR) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P ( + TREE_TYPE (expr3)))))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) { - tree to; + /* copy_class_to_class can be used for class arrays, too. + It just needs to be ensured, that the decl_saved_descriptor + has a way to get to the vptr. */ + tree to, from; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); - tmp = gfc_copy_class_to_class (expr3, to, + /* Only use the array descriptor in expr3_desc, when it is + set and not in a mold= expression. */ + from = expr3_desc == NULL_TREE || code->expr3->mold ? + expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc); + tmp = gfc_copy_class_to_class (from, to, nelems, upoly_expr); } else if (al->expr->ts.type == BT_CLASS) @@ -5731,29 +5756,77 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; + int dim = 0; gfc_expr *temp; gfc_ref *ref = dataref->next; ref->u.ar.type = AR_SECTION; - /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ - dim = 0; - for (; dim < dataref->u.c.component->as->rank; dim++) + if (code->ext.alloc.arr_spec_from_expr3) + { + /* Take the array dimensions from the + source=-expression. */ + gfc_array_ref *source_ref = + gfc_find_array_ref (code->expr3); + if (source_ref->type == AR_FULL) + { + /* For full array refs copy the bounds. */ + for (; dim < dataref->u.c.component->as->rank; dim++) + { + ref->u.ar.dimen_type[dim] = DIMEN_RANGE; + ref->u.ar.start[dim] = + gfc_copy_expr (source_ref->as->lower[dim]); + ref->u.ar.end[dim] = + gfc_copy_expr (source_ref->as->upper[dim]); + } + } + else + { + int sdim = 0; + /* For partial array refs, the partials. */ + for (; dim < dataref->u.c.component->as->rank; + dim++, sdim++) + { + ref->u.ar.dimen_type[dim] = DIMEN_RANGE; + ref->u.ar.start[dim] = + gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1); + /* Skip over element dimensions. */ + while (source_ref->dimen_type[sdim] + == DIMEN_ELEMENT) + ++sdim; + temp = gfc_subtract (gfc_copy_expr ( + source_ref->end[sdim]), + gfc_copy_expr ( + source_ref->start[sdim])); + ref->u.ar.end[dim] = gfc_add (temp, + gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1)); + } + } + } + else { - ref->u.ar.dimen_type[dim] = DIMEN_RANGE; - if (ref->u.ar.end[dim] == NULL) + /* We have to set up the array reference to give ranges + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ + for (; dim < dataref->u.c.component->as->rank; dim++) { - ref->u.ar.end[dim] = ref->u.ar.start[dim]; - temp = gfc_get_int_expr (gfc_default_integer_kind, - &al->expr->where, 1); - ref->u.ar.start[dim] = temp; + ref->u.ar.dimen_type[dim] = DIMEN_RANGE; + if (ref->u.ar.end[dim] == NULL) + { + ref->u.ar.end[dim] = ref->u.ar.start[dim]; + temp = gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1); + ref->u.ar.start[dim] = temp; + } + temp = gfc_subtract (gfc_copy_expr ( + ref->u.ar.end[dim]), + gfc_copy_expr ( + ref->u.ar.start[dim])); + temp = gfc_add (gfc_get_int_expr ( + gfc_default_integer_kind, + &al->expr->where, 1), + temp); } - temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]), - gfc_copy_expr (ref->u.ar.start[dim])); - temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind, - &al->expr->where, 1), - temp); } } if (rhs->ts.type == BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 index f7e0109..59d08d6 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 @@ -1,28 +1,110 @@ -! { dg-do compile } +! { dg-do run } ! ! Contributed by Reinhold Bader ! program assumed_shape_01 - use, intrinsic :: iso_c_binding implicit none - type, bind(c) :: cstruct - integer(c_int) :: i - real(c_float) :: r(2) + type :: cstruct + integer :: i + real :: r(2) end type cstruct - interface - subroutine psub(this, that) bind(c, name='Psub') - import :: c_float, cstruct - real(c_float) :: this(:,:) - type(cstruct) :: that(:) - end subroutine psub - end interface - - real(c_float) :: t(3,7) + type(cstruct), pointer :: u(:) + integer, allocatable :: iv(:), iv2(:) + integer, allocatable :: im(:,:) + integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3]) + integer :: i + integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10]) + + allocate(iv, source= [ 1, 2, 3, 4]) + if (any(iv /= [ 1, 2, 3, 4])) call abort() + deallocate(iv) + + allocate(iv, source=(/(i, i=1,10)/)) + if (any(iv /= (/(i, i=1,10)/))) call abort() + + ! Now 2D + allocate(im, source= cim) + if (any(im /= cim)) call abort() + deallocate(im) + + allocate(im, source= reshape([iv, iv], [2, size(iv, 1)])) + if (any(im /= lcim)) call abort() + deallocate(im) + deallocate(iv) + + allocate(u, source=[cstruct( 4, [1.1,2.2] )] ) + if (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort() + deallocate (u) -! The following is VALID Fortran 2008 but NOT YET supported - allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) ! { dg-error "Array specification required in ALLOCATE statement" } - call psub(t, u) + allocate(iv, source= arrval()) + if (any(iv /= [ 1, 2, 4, 5, 6])) call abort() + ! Check simple array assign + allocate(iv2, source=iv) + if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort() + deallocate(iv, iv2) + + ! Now check for mold= + allocate(iv, mold= [ 1, 2, 3, 4]) + if (any(shape(iv) /= [4])) call abort() + deallocate(iv) + + allocate(iv, mold=(/(i, i=1,10)/)) + if (any(shape(iv) /= [10])) call abort() + + ! Now 2D + allocate(im, mold= cim) + if (any(shape(im) /= shape(cim))) call abort() + deallocate(im) + + allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)])) + if (any(shape(im) /= shape(lcim))) call abort() + deallocate(im) + deallocate(iv) + + allocate(u, mold=[cstruct( 4, [1.1,2.2] )] ) + if (any(shape(u(1)%r(:)) /= 2)) call abort() deallocate (u) + allocate(iv, mold= arrval()) + if (any(shape(iv) /= [5])) call abort() + ! Check simple array assign + allocate(iv2, mold=iv) + if (any(shape(iv2) /= [5])) call abort() + deallocate(iv, iv2) + + call addData([4, 5]) + call addData(["foo", "bar"]) +contains + function arrval() + integer, dimension(5) :: arrval + arrval = [ 1, 2, 4, 5, 6] + end function + + subroutine addData(P) + class(*), intent(in) :: P(:) + class(*), allocatable :: cP(:) + allocate (cP, source= P) + select type (cP) + type is (integer) + if (any(cP /= [4,5])) call abort() + type is (character(*)) + if (len(cP) /= 3) call abort() + if (any(cP /= ["foo", "bar"])) call abort() + class default + call abort() + end select + deallocate (cP) + allocate (cP, mold= P) + select type (cP) + type is (integer) + if (any(size(cP) /= [2])) call abort() + type is (character(*)) + if (len(cP) /= 3) call abort() + if (any(size(cP) /= [2])) call abort() + class default + call abort() + end select + deallocate (cP) + end subroutine end program assumed_shape_01 diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 new file mode 100644 index 0000000..86df531 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Check that allocate with source for arrays without array-spec +! works. +! PR fortran/44672 +! Contributed by Tobias Burnus +! Antony Lewis +! Andre Vehreschild +! + +program allocate_with_source_6 + + type P + class(*), allocatable :: X(:,:) + end type + + type t + end type t + + type(t), allocatable :: a(:), b, c(:) + integer :: num_params_used = 6 + integer, allocatable :: m(:) + + allocate(b,c(5)) + allocate(a(5), source=b) + deallocate(a) + allocate(a, source=c) + allocate(m, source=[(I, I=1, num_params_used)]) + if (any(m /= [(I, I=1, num_params_used)])) call abort() + deallocate(a,b,m) + call testArrays() + +contains + subroutine testArrays() + type L + class(*), allocatable :: v(:) + end type + Type(P) Y + type(L) o + real arr(3,5) + real, allocatable :: v(:) + + arr = 5 + allocate(Y%X, source=arr) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) & + call abort() + class default + call abort() + end select + deallocate(Y%X) + + allocate(Y%X, source=arr(2:3,3:4)) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [4]) /= [5,5,5,5])) & + call abort() + class default + call abort() + end select + deallocate(Y%X) + + allocate(o%v, source=arr(2,3:4)) + select type (R => o%v) + type is (real) + if (any(R /= [5,5])) & + call abort() + class default + call abort() + end select + deallocate(o%v) + + allocate(v, source=arr(2,1:5)) + if (any(v /= [5,5,5,5,5])) call abort() + deallocate(v) + end subroutine testArrays +end + --MP_//WDRtrGEA9m_6orsV9eaypr--