From patchwork Mon Mar 30 17:47:49 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 456272 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 AEB6D1400D5 for ; Tue, 31 Mar 2015 04:48:16 +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=DRrcIiRg; 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:mime-version:content-type; q=dns; s= default; b=lcs3ggnFQJCwZAwkZIyVgE0o/skY9VW1+e6oldzl1IivC9i1ZbLhR Hmt+YK9zt+bH27jz+wdMVk12uwxdFJD0YmvGIjZjJ43HS13LRzFRXWDQQDTXxbdV +nIdDHhwRlxUG/zcJhFx3ecm0WyDFbFtmJWKwGHJpt6SbI8fEWlg70= 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=H80W/jhRbp8dZFrna8fxh2IYguU=; b=DRrcIiRg0WmZ5YUrvYr/ 8iBLQ9Qkx1qOxiDPChSNY4O7W5Zy/5ZOvGfyXA3vXqNjN200FUBD72bKl8Qi+9Lo PiYvh3B1JkeLvokAkbJsz5Hq0S4VUtt0GWo4AYuNGhL6CSQQQyAtYMsvHDx8UeJ4 P3K3rvulSYMIflRNd48BETo= Received: (qmail 110140 invoked by alias); 30 Mar 2015 17:48:03 -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 110009 invoked by uid 89); 30 Mar 2015 17:48:00 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.8 required=5.0 tests=AWL, BAYES_20, 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.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 30 Mar 2015 17:47:58 +0000 Received: from vepi2 ([88.75.104.20]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0MRB8F-1Z2J7g31Id-00Ucjd; Mon, 30 Mar 2015 19:47:52 +0200 Date: Mon, 30 Mar 2015 19:47:49 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML , Antony Lewis Subject: [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec Message-ID: <20150330194749.18e21169@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; 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..73ac873 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,6 +7212,12 @@ 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) { @@ -7375,8 +7392,103 @@ 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, *iter; + 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. */ + iter = ns->code; + /* At least one code has to be present in the ns, this one. */ + if (iter == code) + ns->code = ass; + else + { + while (iter->next && iter->next != code) + iter = iter->next; + gcc_assert (iter->next); + iter->next = ass; + } + ass->next = code; + + /* Do not gfc_free_expr (temp_var), because it is inserted + without copy into expr3. */ + code->expr3 = temp_var; + gfc_set_sym_referenced (temp_var_sym); + } + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0804d45..e1f9e42 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) { 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..8da5420 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,16 +5056,25 @@ 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->ext.alloc.arr_spec_from_expr3) + { + gfc_conv_expr_descriptor (&se, code->expr3); + se.expr = build_fold_indirect_ref (se.expr); + } + else + gfc_conv_expr (&se, code->expr3); if (!code->expr3->mold) expr3 = se.expr; else expr3_tmp = se.expr; + if (code->ext.alloc.arr_spec_from_expr3) + expr3_desc = 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,8 @@ gfc_trans_allocate (gfc_code * code) expr3 = tmp; else expr3_tmp = tmp; + if (code->ext.alloc.arr_spec_from_expr3) + expr3_desc = tmp; /* When he length of a char array is easily available here, fix it for future use. */ if (se.string_length) @@ -5297,7 +5310,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. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 index f7e0109..d2ff2c0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 @@ -1,28 +1,80 @@ -! { 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) + + 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) -! 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(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) +contains + function arrval() + integer, dimension(5) :: arrval + arrval = [ 1, 2, 4, 5, 6] + end function end program assumed_shape_01