From patchwork Thu Apr 2 09:03:30 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 457568 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 0737E14008F for ; Thu, 2 Apr 2015 20:03:52 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass reason="1024-bit key; unprotected key" header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=TgNZ52KC; dkim-adsp=none (unprotected policy); 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:in-reply-to:references:mime-version :content-type; q=dns; s=default; b=RWaNzDIYkH85amOb+0zkPvPrW8HIn /yaH0XUDvsMV9HVxeBKvtA2aNtYApcFHUzQ0tpop41IGnyj4K2Bnl7KuCVQjs3yW uHF3m69Zln6nIZirvn3urLpY3Wllv/hi7/+dkCeNecOsCOmgKLI1MOFVlHMKSr+Z 6qb600FGDnJqqE= 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:in-reply-to:references:mime-version :content-type; s=default; bh=MeucD53U+JRf6TzbU9lyNyTGunQ=; b=TgN Z52KCWp+mrNP3x7t2RHjkhf0oCxY4LMJ5tN30hwg1eRrA8YXRNBWXPEG1+8FDLvY DK2suTcSvaxv9Iqm5BBNxHIbG/+ffXNsRlzS+PrS6+1/dKLmUlam9mnYSTszZTRr I/A2plHmEdux0qbsVHH1OUSicfitO+j6Z4zRcBhg= Received: (qmail 61282 invoked by alias); 2 Apr 2015 09:03:43 -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 61265 invoked by uid 89); 2 Apr 2015 09:03:42 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.8 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; Thu, 02 Apr 2015 09:03:39 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0M5IdH-1ZNCFF2Jhv-00zUR2; Thu, 02 Apr 2015 11:03:35 +0200 Date: Thu, 2 Apr 2015 11:03:30 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML , Antony Lewis , Paul Richard Thomas Subject: Re: [Patch, fortran, PR44672, v3] [F08] ALLOCATE with SOURCE and no array-spec Message-ID: <20150402110330.45ad027b@vepi2> In-Reply-To: <20150401151540.4979eb07@vepi2> References: <20150330194749.18e21169@vepi2> <20150401151540.4979eb07@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, during debugging of a larger fortran source I figured that my previous patch on 44672 had still some issues, when it comes to adding a gfc_code into the chain of codes and with a symbol. Adding a new gfc_code object before the current one is now solved be creating a new gfc_code object, copying the current one to the new one, initialize the old one to the new data and setting its next pointer to the current one. Because in the gfc_code.ext.alloc a flag is introduced, that is only set by the C-code adding a new gfc_code object, that flag can be used to prevent doing this process endlessly. I also learned, that one has to commit newly created symbols or one may get a very strange error in an assert in gfc_enforce_clean_symbol_state (). After adding the gfc_commit_symbol () everything was fine. Bootstraps and regtests ok on x86_64-linux-gnu/F20. Ok for 5.2 trunk? Regards, Andre On Wed, 1 Apr 2015 15:15:40 +0200 Andre Vehreschild wrote: > Hi all, > > during debugging another fortran code, I figured that some cases were not yet > met. Especially the case where a class array is in the source= or mold= > expression. This new version of the patch fixes the issue now. > > Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > Ok for 5.2 trunk? > > Regards, > Andre > > On Mon, 30 Mar 2015 19:47:49 +0200 > Andre Vehreschild wrote: > > > Dear all, > > > > please find attach a patch fixing pr44672: > > > > integer, dimension(:) :: arr > > allocate(arr, source = [1,2,3]) > > > > as for F2008:C633 now is no longer flagged, beside when you insist on > > -std=f2003 or lower. Furthermore does the patch implement the F2008 feature > > of obsoleting the explicit array specification on the arrays to allocate, > > when an array valued source=/mold= expression is given. > > > > Bootstrap and regtests ok on x86_64-linux-gnu/F20. > > > > This batched is based on a trunk having my latest for pr60322 patched in > > (else deltas may occur). > > > > Ok for 5.2 trunk? > > > > Regards, > > Andre > > diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 643cd6a..9835edc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2394,6 +2394,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 316b413..21add32 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,9 +7103,20 @@ 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 @@ -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,23 @@ failure: return false; } + +static gfc_code * +build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, + gfc_component *comp1, gfc_component *comp2, locus loc); + + 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 +7397,97 @@ 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) + { + gfc_array_dimen_size (code->expr3, dim, &dim_size); + 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 0804d45..f1db69c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4981,7 +4981,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,20 +5025,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* 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); - } + 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, @@ -5052,10 +5058,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; @@ -5225,6 +5235,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*/ @@ -5232,7 +5269,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; @@ -5250,21 +5287,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) { @@ -5300,7 +5340,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; @@ -5317,7 +5358,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, size = gfc_array_init_size (se->expr, 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) { @@ -7054,6 +7095,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 8544534..389a644 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-stmt.c b/gcc/fortran/trans-stmt.c index 68b343b..060af8f 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4974,7 +4974,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; @@ -4986,6 +4986,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); @@ -5040,12 +5041,13 @@ gfc_trans_allocate (gfc_code * code) /* A array expr3 needs the scalarizer, therefore do not process it here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) + if (code->ext.alloc.arr_spec_from_expr3 + || (code->expr3->expr_type != EXPR_ARRAY + && (code->expr3->rank == 0 + || code->expr3->expr_type == EXPR_FUNCTION) + && (!code->expr3->symtree + || !code->expr3->symtree->n.sym->as) + && !gfc_is_class_array_ref (code->expr3, NULL))) { /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ @@ -5054,17 +5056,26 @@ 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); - se.want_pointer = 1; - gfc_conv_expr (&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; + { + se.want_pointer = 1; + gfc_conv_expr (&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); } @@ -5102,6 +5113,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) @@ -5297,7 +5312,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. @@ -5501,17 +5517,25 @@ gfc_trans_allocate (gfc_code * code) /* Initialization via SOURCE block (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (expr3 != NULL_TREE - && ((POINTER_TYPE_P (TREE_TYPE (expr3)) - && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + if (((expr3 != NULL_TREE + && ((POINTER_TYPE_P (TREE_TYPE (expr3)) + && TREE_CODE (expr3) != POINTER_PLUS_EXPR) + || VAR_P (expr3))) + || expr3_desc != NULL_TREE) && 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 (code->expr3->ts.type == BT_CHARACTER) 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