* [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec @ 2015-03-30 17:48 Andre Vehreschild 2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-03-30 17:48 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis [-- Attachment #1: Type: text/plain, Size: 632 bytes --] 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 -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_1.clog --] [-- Type: application/octet-stream, Size: 1226 bytes --] gcc/testsuite/ChangeLog: 2015-03-30 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_3.f90: Enhanced to check implementation of F2008:C633. gcc/fortran/ChangeLog: 2015-03-30 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. Generate temporay variable assignment to allow source-expressions without explicit array specification. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_1.patch --] [-- Type: text/x-patch, Size: 18162 bytes --] 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v2] [F08] ALLOCATE with SOURCE and no array-spec 2015-03-30 17:48 [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec Andre Vehreschild @ 2015-04-01 13:15 ` Andre Vehreschild 2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-04-01 13:15 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis [-- Attachment #1: Type: text/plain, Size: 1064 bytes --] 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 <vehre@gmx.de> 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 -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_2.clog --] [-- Type: application/octet-stream, Size: 444 bytes --] gcc/testsuite/ChangeLog: 2015-04-01 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_3.f90: gcc/fortran/ChangeLog: 2015-04-01 Andre Vehreschild <vehre@gmx.de> * gfortran.h: * resolve.c (resolve_allocate_expr): (resolve_allocate_deallocate): * trans-array.c (gfc_array_init_size): (retrieve_last_ref): (gfc_array_allocate): (gfc_conv_expr_descriptor): * trans-array.h: * trans-stmt.c (gfc_trans_allocate): [-- Attachment #3: pr44672_2.patch --] [-- Type: text/x-patch, Size: 20907 bytes --] 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..ce2e29e 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]) @@ -7375,8 +7386,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..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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v3] [F08] ALLOCATE with SOURCE and no array-spec 2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild @ 2015-04-02 9:03 ` Andre Vehreschild 2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-04-02 9:03 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis, Paul Richard Thomas [-- Attachment #1: Type: text/plain, Size: 2121 bytes --] 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 <vehre@gmx.de> 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 <vehre@gmx.de> 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 > > -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_3.patch --] [-- Type: text/x-patch, Size: 21379 bytes --] 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 [-- Attachment #3: pr44672_3.clog --] [-- Type: application/octet-stream, Size: 1362 bytes --] gcc/testsuite/ChangeLog: 2015-04-02 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_3.f90: Enhanced to check implementation of F2008:C633. gcc/fortran/ChangeLog: 2015-04-02 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. Generate temporay variable assignment to allow source-expressions without explicit array specification. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Ping, Patch, fortran, PR44672, v3] [F08] ALLOCATE with SOURCE and no array-spec 2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild @ 2015-04-23 12:45 ` Andre Vehreschild 2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-04-23 12:45 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis, Paul Richard Thomas Ping ! On Thu, 2 Apr 2015 11:03:30 +0200 Andre Vehreschild <vehre@gmx.de> wrote: > 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 <vehre@gmx.de> 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 <vehre@gmx.de> 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 > > > > > > -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v4] [F08] ALLOCATE with SOURCE and no array-spec 2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild @ 2015-04-29 15:29 ` Andre Vehreschild 2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-04-29 15:29 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 1241 bytes --] 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 [-- Attachment #2: pr44672_4.clog --] [-- Type: application/octet-stream, Size: 1490 bytes --] gcc/testsuite/ChangeLog: 2015-04-29 Andre Vehreschild <vehre@gmx.de> * gfortran.dg/allocate_with_source_3.f90: Enhanced to check implementation of F2008:C633. gcc/fortran/ChangeLog: 2015-04-29 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. Generate temporay variable assignment to allow source-expressions without explicit array specification. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Prevent array constructors for allocatable components to generate deallocate code. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_4.patch --] [-- Type: text/x-patch, Size: 22022 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 832a6ce..9b5f4cf 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..41b128a 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,96 @@ 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 a17f431..08c8861 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4982,7 +4982,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; @@ -5025,20 +5026,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, @@ -5053,10 +5059,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; @@ -5226,6 +5236,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*/ @@ -5233,7 +5270,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; @@ -5251,21 +5288,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) { @@ -5301,7 +5341,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; @@ -5318,7 +5359,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) { @@ -7057,6 +7098,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 76bad2a..2132f84 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 9c5ce7d..19869c3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5340,7 +5340,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 1e435be..dcad9bc 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; @@ -5116,6 +5116,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); @@ -5173,21 +5174,30 @@ 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); } @@ -5228,7 +5238,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)) { tmp = build_fold_indirect_ref_loc (input_location, @@ -5241,6 +5251,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) @@ -5439,7 +5453,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. @@ -5643,17 +5658,26 @@ 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) && 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 (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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v5] [F08] ALLOCATE with SOURCE and no array-spec 2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild @ 2015-04-30 14:31 ` Andre Vehreschild 2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-04-30 14:31 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 2480 bytes --] 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 <vehre@gmx.de> 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 [-- Attachment #2: pr44672_5.clog --] [-- Type: application/octet-stream, Size: 1597 bytes --] gcc/testsuite/ChangeLog: 2015-04-30 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.dg/allocate_with_source_3.f90: Enhanced to check implementation of F2008:C633. * gfortran.dg/allocate_with_source_6.f08: New test. gcc/fortran/ChangeLog: 2015-04-30 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. Generate temporay variable assignment to allow source-expressions without explicit array specification. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Prevent array constructors for allocatable components to generate deallocate code. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_5.patch --] [-- Type: text/x-patch, Size: 28718 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 832a6ce..9b5f4cf 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..41026af 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,108 @@ 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 a17f431..8c0c90e 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4982,7 +4982,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; @@ -4997,7 +4998,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; @@ -5012,6 +5013,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; @@ -5021,24 +5027,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, @@ -5053,10 +5064,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; @@ -5226,6 +5241,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*/ @@ -5233,7 +5275,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; @@ -5251,21 +5293,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) { @@ -5301,7 +5346,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; @@ -5315,10 +5361,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) { @@ -7057,6 +7104,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 76bad2a..2132f84 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 9c5ce7d..19869c3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5340,7 +5340,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 1e435be..9cbb6aa 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; @@ -5116,6 +5116,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); @@ -5173,21 +5174,30 @@ 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); } @@ -5228,7 +5238,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)) { tmp = build_fold_indirect_ref_loc (input_location, @@ -5241,6 +5251,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) @@ -5439,7 +5453,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. @@ -5643,17 +5658,26 @@ 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) && 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 (code->expr3->ts.type == BT_CHARACTER) @@ -5731,29 +5755,73 @@ 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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild @ 2015-05-19 10:29 ` Andre Vehreschild 2015-05-22 10:24 ` Ping: " Andre Vehreschild 2015-05-25 19:35 ` Mikael Morin 0 siblings, 2 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-05-19 10:29 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 3023 bytes --] 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 <vehre@gmx.de> 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 <vehre@gmx.de> 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 [-- Attachment #2: pr44672_6.clog --] [-- Type: application/octet-stream, Size: 1597 bytes --] gcc/testsuite/ChangeLog: 2015-05-19 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.dg/allocate_with_source_3.f90: Enhanced to check implementation of F2008:C633. * gfortran.dg/allocate_with_source_6.f08: New test. gcc/fortran/ChangeLog: 2015-05-19 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. Generate temporay variable assignment to allow source-expressions without explicit array specification. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Prevent array constructors for allocatable components to generate deallocate code. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_6.patch --] [-- Type: text/x-patch, Size: 28734 bytes --] 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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + ^ permalink raw reply [flat|nested] 21+ messages in thread
* Ping: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild @ 2015-05-22 10:24 ` Andre Vehreschild 2015-05-25 19:35 ` Mikael Morin 1 sibling, 0 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-05-22 10:24 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML Hi, the patch (65548) this one depends on is in trunk now. Still bootstraps ok and regtests with the issue in gfortran.dg/alloc_comp_constructor_1.f90 (which is addressed by the patch for pr58586 already) on x86_64-linux-gnu/f21. Ok for trunk? - Andre On Tue, 19 May 2015 12:26:02 +0200 Andre Vehreschild <vehre@gmx.de> wrote: > 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 <vehre@gmx.de> 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 <vehre@gmx.de> 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild 2015-05-22 10:24 ` Ping: " Andre Vehreschild @ 2015-05-25 19:35 ` Mikael Morin 2015-05-28 15:48 ` Andre Vehreschild 1 sibling, 1 reply; 21+ messages in thread From: Mikael Morin @ 2015-05-25 19:35 UTC (permalink / raw) To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML Le 19/05/2015 12:26, Andre Vehreschild a écrit : > 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! > Let's start now. ;-) I don't understand why one of your previous patches was factoring the source expression evaluation to a temporary in gfc_trans_allocate, and now with this patch you do the same thing in gfc_resolve_allocate, not reusing the part in gfc_trans_allocate. > *************** failure: > *** 7201,7212 **** > --- 7212,7229 ---- > 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; > + I expect you'll miss some error messages by doing this. Where is the endless loop? > *************** resolve_allocate_deallocate (gfc_code *c > *** 7375,7382 **** > --- 7392,7500 ---- > > 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, &arr_alloc_wo_spec); > ! > ! if (arr_alloc_wo_spec && code->expr3) > ! { [...] > ! > ! ass = gfc_get_code (EXEC_ASSIGN); This memory is not freed as far as I know. I think you can use a local variable for it. *** /tmp/PRaWHc_trans-expr.c 2015-05-25 19:54:35.056309429 +0200 --- /tmp/7e82nd_trans-expr.c 2015-05-25 19:54:35.058309429 +0200 *************** gfc_conv_procedure_call (gfc_se * se, gf *** 5328,5334 **** 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)) { int parm_rank; tmp = build_fold_indirect_ref_loc (input_location, --- 5328,5335 ---- 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_STRUCTURE) { int parm_rank; tmp = build_fold_indirect_ref_loc (input_location, Can't you remove this? It's undone by the PR58586 patch. > *************** gfc_trans_allocate (gfc_code * code) > *** 5733,5746 **** > > if (dataref && dataref->u.c.component->as) > { > ! int dim; > 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++) > { > ref->u.ar.dimen_type[dim] = DIMEN_RANGE; > --- 5758,5815 ---- > > if (dataref && dataref->u.c.component->as) > { > ! int dim = 0; > gfc_expr *temp; > gfc_ref *ref = dataref->next; > ref->u.ar.type = AR_SECTION; > + 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); Does this work? code->expr3 is not always a variable. > + 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]); > + } This won't work. Consider this: block integer :: a(n) n = n+1 allocate(b, source=a) end block You have to use a full array ref. In fact you can use a full array ref everywhere, I think. That's all for now. Mikael ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-25 19:35 ` Mikael Morin @ 2015-05-28 15:48 ` Andre Vehreschild 2015-05-28 18:42 ` Mikael Morin 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-05-28 15:48 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 5276 bytes --] Hi Mikael, thanks for the comments so far. > I don't understand why one of your previous patches was factoring the > source expression evaluation to a temporary in gfc_trans_allocate, and > now with this patch you do the same thing in gfc_resolve_allocate, not > reusing the part in gfc_trans_allocate. When I remember correctly, then at the time of writing this patch the one factoring out the temporary in gfc_trans_allocate() was not doing that yet. At least it was not doing it always as needed. Therefore we are looking at a kind of history here already. > > > *************** failure: > > *** 7201,7212 **** > > --- 7212,7229 ---- > > 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; > > + > I expect you'll miss some error messages by doing this. > Where is the endless loop? This has been removed. The endless loop was triggered by gfc_resolve_code () in line 179 of the patch, which is now in chunk that is mostly removed. > > *************** resolve_allocate_deallocate (gfc_code *c > > *** 7375,7382 **** > > --- 7392,7500 ---- > > > > 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, &arr_alloc_wo_spec); > > ! > > ! if (arr_alloc_wo_spec && code->expr3) > > ! { > [...] > > ! > > ! ass = gfc_get_code (EXEC_ASSIGN); > This memory is not freed as far as I know. > I think you can use a local variable for it. Complete block removed. Therefore fixed. > *** /tmp/PRaWHc_trans-expr.c 2015-05-25 19:54:35.056309429 +0200 > --- /tmp/7e82nd_trans-expr.c 2015-05-25 19:54:35.058309429 +0200 > *************** gfc_conv_procedure_call (gfc_se * se, gf > *** 5328,5334 **** > 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)) > { > int parm_rank; > tmp = build_fold_indirect_ref_loc (input_location, > --- 5328,5335 ---- > 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_STRUCTURE) > { > int parm_rank; > tmp = build_fold_indirect_ref_loc (input_location, > > Can't you remove this? It's undone by the PR58586 patch. Removed, looks like an artefact of a long forgotten need. > > *************** gfc_trans_allocate (gfc_code * code) > > *** 5733,5746 **** > > > > if (dataref && dataref->u.c.component->as) > > { > > ! int dim; > > 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++) > > { > > ref->u.ar.dimen_type[dim] = DIMEN_RANGE; > > --- 5758,5815 ---- > > > > if (dataref && dataref->u.c.component->as) > > { > > ! int dim = 0; > > gfc_expr *temp; > > gfc_ref *ref = dataref->next; > > ref->u.ar.type = AR_SECTION; > > + 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); > Does this work? code->expr3 is not always a variable. The block removed from resolve_allocate() ensured, that this was always a variable. Therefore, yes, it had to work then. Now, we of course have far more trouble. > > > + 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]); > > + } > This won't work. Consider this: > block > integer :: a(n) > n = n+1 > allocate(b, source=a) > end block > > You have to use a full array ref. In fact you can use a full array ref > everywhere, I think. I don't get you there. Using a full array ref produces numerous regressions. Have a look at the current patch. The full array ref is in the #if-#else-#endif's #else block. Any ideas? Bootstraps and regtests fine on x86_64-linux-gnu. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_7.patch --] [-- Type: text/x-patch, Size: 27404 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 905d47c..211c781 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 e615cc6..315170a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6805,7 +6805,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; @@ -7104,13 +7104,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; @@ -7125,7 +7136,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]) @@ -7202,6 +7213,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8fab45..014ee53 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5005,7 +5005,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; @@ -5020,7 +5021,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; @@ -5035,6 +5036,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; @@ -5044,24 +5050,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) + if (expr3_desc != NULL_TREE) se.expr = gfc_index_one_node; 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, @@ -5076,10 +5087,25 @@ 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) + { + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + se.expr = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + } + 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; @@ -5249,6 +5275,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*/ @@ -5256,7 +5309,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; @@ -5274,21 +5327,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) { @@ -5324,7 +5380,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; @@ -5338,10 +5395,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) { @@ -7080,6 +7138,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..3916836 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5328,7 +5328,7 @@ 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) { 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 81943b0..c9c112f 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; @@ -5229,7 +5240,9 @@ gfc_trans_allocate (gfc_code * code) } else tmp = se.expr; - if (!code->expr3->mold) + if (code->ext.alloc.arr_spec_from_expr3) + expr3_desc = tmp; + else if (!code->expr3->mold) expr3 = tmp; else expr3_tmp = tmp; @@ -5291,6 +5304,7 @@ gfc_trans_allocate (gfc_code * code) } else { + tree inexpr3; /* When the object to allocate is polymorphic type, then it needs its vtab set correctly, so deduce the required _vtab and _len from the source expression. */ @@ -5339,7 +5353,9 @@ gfc_trans_allocate (gfc_code * code) don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + inexpr3 = expr3_desc ? expr3_desc : expr3; + if (inexpr3 != NULL_TREE && DECL_P (inexpr3) + && DECL_ARTIFICIAL (inexpr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5349,11 +5365,11 @@ gfc_trans_allocate (gfc_code * code) gfc_create_var () took care about generating the identifier. */ newsym->name = gfc_get_string (IDENTIFIER_POINTER ( - DECL_NAME (expr3))); + DECL_NAME (inexpr3))); newsym->n.sym = gfc_new_symbol (newsym->name, NULL); /* The backend_decl is known. It is expr3, which is inserted here. */ - newsym->n.sym->backend_decl = expr3; + newsym->n.sym->backend_decl = inexpr3; e3rhs = gfc_get_expr (); e3rhs->ts = code->expr3->ts; e3rhs->rank = code->expr3->rank; @@ -5379,7 +5395,7 @@ gfc_trans_allocate (gfc_code * code) newsym->n.sym->as = arr; gfc_add_full_array_ref (e3rhs, arr); } - else if (POINTER_TYPE_P (TREE_TYPE (expr3))) + else if (POINTER_TYPE_P (TREE_TYPE (inexpr3))) newsym->n.sym->attr.pointer = 1; /* The string length is known to. Set it for char arrays. */ if (e3rhs->ts.type == BT_CHARACTER) @@ -5490,7 +5506,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, + e3rhs ? e3rhs : code->expr3, expr3_desc)) { /* A scalar or derived type. First compute the size to allocate. @@ -5693,17 +5710,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) @@ -5734,30 +5760,86 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; +#if 1 + 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 (e3rhs ? e3rhs : 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); } +#else + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, + gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs + : code->expr3)); +#endif } 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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-28 15:48 ` Andre Vehreschild @ 2015-05-28 18:42 ` Mikael Morin 2015-05-29 12:41 ` Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Mikael Morin @ 2015-05-28 18:42 UTC (permalink / raw) To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 8511 bytes --] Le 28/05/2015 17:29, Andre Vehreschild a écrit : > *************** resolve_allocate_expr (gfc_expr *e, gfc_ > *** 7103,7112 **** > --- 7103,7123 ---- > if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL > || (dimension && ref2->u.ar.dimen == 0)) > { > + /* 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. */ I think we can be a little be more user friendly with the gfc_notify_std error message. Something like: ALLOCATE without array spec at %L ALLOCATE with array bounds determined from SOURCE or MOLD at %L > *************** gfc_array_init_size (tree descriptor, in > *** 5044,5053 **** > 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; > else > --- 5050,5063 ---- > lower == NULL => lbound = 1, ubound = upper[n] > upper[n] = NULL => lbound = 1, ubound = lower[n] > upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ > > /* Set lower bound. */ > gfc_init_se (&se, NULL); > + if (expr3_desc != NULL_TREE) > + se.expr = gfc_index_one_node; > + else > + { > + ubound = upper[n]; > if (lower == NULL) > se.expr = gfc_index_one_node; > else > *************** gfc_array_init_size (tree descriptor, in > *** 5064,5069 **** > --- 5074,5080 ---- > ubound = lower[n]; > } > } > + } > gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, > gfc_rank_cst[n], se.expr); > conv_lbound = se.expr; You can avoid reindenting if the ubound = upper[n] statement is kept at its original place. > *************** gfc_array_init_size (tree descriptor, in > *** 5076,5085 **** > > /* 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); > ! > gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, > gfc_rank_cst[n], se.expr); > conv_ubound = se.expr; > --- 5087,5111 ---- > > /* Set upper bound. */ > gfc_init_se (&se, NULL); > + if (expr3_desc != NULL_TREE) > + { > + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */ > + tmp = fold_build2_loc (input_location, MINUS_EXPR, > + gfc_array_index_type, > + gfc_conv_descriptor_ubound_get ( > + expr3_desc, gfc_rank_cst[n]), > + gfc_conv_descriptor_lbound_get ( > + expr3_desc, gfc_rank_cst[n])); > + se.expr = fold_build2_loc (input_location, PLUS_EXPR, > + gfc_array_index_type, tmp, > + gfc_index_one_node); > + } > + 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; Your one-based-ness problem was here, wasn't it? I would rather copy directly lbound and ubound from expr3_desc to descriptor. If the source has non-one-based bounds, the above would produce wrong bounds. > *************** gfc_trans_allocate (gfc_code * code) > *** 5174,5185 **** > { > if (!code->expr3->mold > || code->expr3->ts.type == BT_CHARACTER > ! || vtab_needed) > { > /* 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 > --- 5175,5195 ---- > { > if (!code->expr3->mold > || code->expr3->ts.type == BT_CHARACTER > ! || vtab_needed > ! || code->ext.alloc.arr_spec_from_expr3) > { > /* Convert expr3 to a tree. */ > gfc_init_se (&se, NULL); > ! if (code->ext.alloc.arr_spec_from_expr3) > ! { > ! gfc_conv_expr_descriptor (&se, code->expr3); > ! expr3_desc = se.expr; > ! } > ! else > ! { > ! /* 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_trans_allocate (gfc_code * code) > *** 5189,5194 **** > --- 5199,5205 ---- > 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); > } This is skipping over setting expr3_len, is it on purpose? Would it make sense to merge the two calls to gfc_conv_expr_descriptor? > *************** gfc_trans_allocate (gfc_code * code) > *** 5229,5235 **** > } > else > tmp = se.expr; > ! if (!code->expr3->mold) > expr3 = tmp; > else > expr3_tmp = tmp; > --- 5240,5248 ---- > } > else > tmp = se.expr; > ! if (code->ext.alloc.arr_spec_from_expr3) > ! expr3_desc = tmp; > ! else if (!code->expr3->mold) > expr3 = tmp; > else > expr3_tmp = tmp; Couldn't expr3 be reused? We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc, and (below) inexpr3. :-( > *************** gfc_trans_allocate (gfc_code * code) > *** 5291,5296 **** > --- 5304,5310 ---- > } > else > { > + tree inexpr3; > /* When the object to allocate is polymorphic type, then it > needs its vtab set correctly, so deduce the required _vtab > and _len from the source expression. */ > *************** gfc_trans_allocate (gfc_code * code) > *** 5339,5345 **** > don't have to take care about scalar to array treatment and > will benefit of every enhancements gfc_trans_assignment () > gets. */ > ! if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) > { > /* Build a temporary symtree and symbol. Do not add it to > the current namespace to prevent accidently modifying > --- 5353,5361 ---- > don't have to take care about scalar to array treatment and > will benefit of every enhancements gfc_trans_assignment () > gets. */ > ! inexpr3 = expr3_desc ? expr3_desc : expr3; > ! if (inexpr3 != NULL_TREE && DECL_P (inexpr3) > ! && DECL_ARTIFICIAL (inexpr3)) > { > /* Build a temporary symtree and symbol. Do not add it to > the current namespace to prevent accidently modifying > [...] >>> + 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]); >>> + } >> This won't work. Consider this: >> block >> integer :: a(n) >> n = n+1 >> allocate(b, source=a) >> end block >> >> You have to use a full array ref. In fact you can use a full array ref >> everywhere, I think. > > I don't get you there. Using a full array ref produces numerous regressions. > Have a look at the current patch. The full array ref is in the > #if-#else-#endif's #else block. Any ideas? > The attached patch seems to work. It is basically the same as your #else branch. I think the problem was gfc_get_full_arrayspec_from_expr can return NULL in some cases. Mikael [-- Attachment #2: pr44672_v7.1.diff --] [-- Type: text/x-patch, Size: 3185 bytes --] diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index a2f8216..b3d3ddc 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5759,86 +5759,15 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { -#if 1 - int dim = 0; - gfc_expr *temp; - gfc_ref *ref = dataref->next; - ref->u.ar.type = AR_SECTION; - 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 (e3rhs ? e3rhs : 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 - { - /* 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.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); - } - } -#else + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); dataref->next = NULL; - gfc_add_full_array_ref (last_arg->expr, - gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs - : code->expr3)); -#endif + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-28 18:42 ` Mikael Morin @ 2015-05-29 12:41 ` Andre Vehreschild 2015-05-30 4:23 ` Thomas Koenig 2015-06-02 16:52 ` Mikael Morin 0 siblings, 2 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-05-29 12:41 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 6130 bytes --] Hi Mikael, comments inline below: On Thu, 28 May 2015 20:06:57 +0200 Mikael Morin <mikael.morin@sfr.fr> wrote: > Le 28/05/2015 17:29, Andre Vehreschild a écrit : > > *************** resolve_allocate_expr (gfc_expr *e, gfc_ > > *** 7103,7112 **** > > --- 7103,7123 ---- > > if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL > > || (dimension && ref2->u.ar.dimen == 0)) > > { > > + /* 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. */ > I think we can be a little be more user friendly with the gfc_notify_std > error message. > Something like: > ALLOCATE without array spec at %L > ALLOCATE with array bounds determined from SOURCE or MOLD at %L I didn't want to mess with the error messages to prevent issues for translations. So how is the policy on this? > > *************** gfc_array_init_size (tree descriptor, in > > *** 5044,5053 **** > > 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; > > else > > --- 5050,5063 ---- > > lower == NULL => lbound = 1, ubound = upper[n] > > upper[n] = NULL => lbound = 1, ubound = lower[n] > > upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ > > > > /* Set lower bound. */ > > gfc_init_se (&se, NULL); > > + if (expr3_desc != NULL_TREE) > > + se.expr = gfc_index_one_node; > > + else > > + { > > + ubound = upper[n]; > > if (lower == NULL) > > se.expr = gfc_index_one_node; > > else > > *************** gfc_array_init_size (tree descriptor, in > > *** 5064,5069 **** > > --- 5074,5080 ---- > > ubound = lower[n]; > > } > > } > > + } > > gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, > > gfc_rank_cst[n], se.expr); > > conv_lbound = se.expr; > You can avoid reindenting if the ubound = upper[n] statement is kept at > its original place. Fixed. > > *************** gfc_array_init_size (tree descriptor, in > > *** 5076,5085 **** > > > > /* 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); > > ! > > gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, > > gfc_rank_cst[n], se.expr); > > conv_ubound = se.expr; > > --- 5087,5111 ---- > > > > /* Set upper bound. */ > > gfc_init_se (&se, NULL); > > + if (expr3_desc != NULL_TREE) > > + { > > + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */ > > + tmp = fold_build2_loc (input_location, MINUS_EXPR, > > + gfc_array_index_type, > > + gfc_conv_descriptor_ubound_get ( > > + expr3_desc, gfc_rank_cst[n]), > > + gfc_conv_descriptor_lbound_get ( > > + expr3_desc, gfc_rank_cst[n])); > > + se.expr = fold_build2_loc (input_location, PLUS_EXPR, > > + gfc_array_index_type, tmp, > > + gfc_index_one_node); > > + } > > + 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; > Your one-based-ness problem was here, wasn't it? Correct. > I would rather copy directly lbound and ubound from expr3_desc to > descriptor. It was that way in the previous version of the patch, which does *not* work any longer. When gfc_trans_allocate () is responsible for the creating a temporary variable for the source=-expression, then it does so using zero based expressions. > If the source has non-one-based bounds, the above would produce wrong > bounds. Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable created by conv_expr_descriptor, aka zero-based. <snipp> > > *************** gfc_trans_allocate (gfc_code * code) > > *** 5229,5235 **** > > } > > else > > tmp = se.expr; > > ! if (!code->expr3->mold) > > expr3 = tmp; > > else > > expr3_tmp = tmp; > > --- 5240,5248 ---- > > } > > else > > tmp = se.expr; > > ! if (code->ext.alloc.arr_spec_from_expr3) > > ! expr3_desc = tmp; > > ! else if (!code->expr3->mold) > > expr3 = tmp; > > else > > expr3_tmp = tmp; > Couldn't expr3 be reused? > We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc, > and (below) inexpr3. :-( Of course can we use just two variables for all expressions. I have removed the expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which stores which kind the expr3 is, aka unset, source, mold, desc. This makes the code simpler at some places. Attached is a new version of the patch. This one fails allocate_with_source_3.f90 on runtime, where I don't see the issue currently. May be you have some luck and time. If not I will investigate on Monday. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_7.1.patch --] [-- Type: text/x-patch, Size: 26205 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 905d47c..211c781 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 e615cc6..315170a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6805,7 +6805,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; @@ -7104,13 +7104,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; @@ -7125,7 +7136,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]) @@ -7202,6 +7213,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8fab45..6a31396 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5005,7 +5005,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; @@ -5020,7 +5021,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; @@ -5035,6 +5036,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,7 +5054,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + se.expr = gfc_index_one_node; + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5076,10 +5084,25 @@ 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) + { + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + se.expr = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + } + 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; @@ -5249,6 +5272,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*/ @@ -5256,7 +5306,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; @@ -5274,21 +5324,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) { @@ -5324,7 +5377,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; @@ -5338,10 +5392,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) { @@ -7080,6 +7135,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..3916836 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5328,7 +5328,7 @@ 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) { 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 81943b0..43bc34a 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5105,6 +5105,8 @@ gfc_trans_allocate (gfc_code * code) 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; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5117,6 +5119,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; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5156,10 +5159,7 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; @@ -5174,25 +5174,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); - /* For all "simple" expression just get the descriptor or the - reference, respectively, depending on the rank of the expr. */ - if (code->expr3->rank != 0) + /* For all "simple" expression just get the descriptor + or the reference, respectively, depending on the + rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || 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; + /* Create a temp variable only for component refs. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); } - /* else expr3 = NULL_TREE set above. */ + else + se.expr = NULL_TREE; } else { @@ -5212,32 +5213,41 @@ gfc_trans_allocate (gfc_code * code) code->expr3->ts, false, true, false, false); + temp_var_needed = !VAR_P (se.expr); 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. */ - if (!VAR_P (se.expr)) - { - tree var; - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "atmp"); - gfc_add_modify_loc (input_location, &block, var, tmp); - tmp = var; - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; /* When he length of a char array is easily available - here, fix it for future use. */ + here, fix it for future use. */ if (se.string_length) expr3_len = gfc_evaluate_now (se.string_length, &block); } + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); + expr3 = var; + } + else + expr3 = se.expr; + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5252,10 +5262,6 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) - && (VAR_P (expr3_tmp) || !code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5275,9 +5281,7 @@ gfc_trans_allocate (gfc_code * code) { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5338,8 +5342,11 @@ gfc_trans_allocate (gfc_code * code) advantage is, that we get scalarizer support for free, don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () - gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code) } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5490,7 +5503,9 @@ 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, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE)) { /* A scalar or derived type. First compute the size to allocate. @@ -5696,11 +5711,15 @@ gfc_trans_allocate (gfc_code * code) 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)))) + || (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)) { + /* 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; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, @@ -5734,30 +5753,14 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; - 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++) - { - 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); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5839,7 +5842,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its 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_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 new file mode 100644 index 0000000..86df531 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-29 12:41 ` Andre Vehreschild @ 2015-05-30 4:23 ` Thomas Koenig 2015-06-02 16:52 ` Mikael Morin 1 sibling, 0 replies; 21+ messages in thread From: Thomas Koenig @ 2015-05-30 4:23 UTC (permalink / raw) To: Andre Vehreschild, Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML Hi Andre, just a couple of remarks. You are adding significant new code to an existing test case, allocate_with_source_3.f90. As discussed previously, it would be better to put the new code into an extra test case. The following test case segfaults with your patch with an "invalid free": module foo contains integer function f() f = 2 end function f end module foo program main use foo integer :: n n = 42 block real, dimension(0:n) :: a real, dimension(:), allocatable :: c call random_number(a) allocate(c,source=a(:f())) end block end program main You could also add n = n - 1 allocate(c,source=a) if (size(a,1) /= size(c,1)) call abort to the test case above to make sure that changing a variable that was used to declare an array bound does not lead to wrong code. Regards Thomas ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-05-29 12:41 ` Andre Vehreschild 2015-05-30 4:23 ` Thomas Koenig @ 2015-06-02 16:52 ` Mikael Morin 2015-06-03 15:25 ` Andre Vehreschild 1 sibling, 1 reply; 21+ messages in thread From: Mikael Morin @ 2015-06-02 16:52 UTC (permalink / raw) To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML Hello Andre, comments below (out of order, sorry). Le 29/05/2015 13:46, Andre Vehreschild a écrit : > Hi Mikael, > > comments inline below: > > On Thu, 28 May 2015 20:06:57 +0200 > Mikael Morin <mikael.morin@sfr.fr> wrote: > >> Le 28/05/2015 17:29, Andre Vehreschild a écrit : >>> *************** resolve_allocate_expr (gfc_expr *e, gfc_ >>> *** 7103,7112 **** >>> --- 7103,7123 ---- >>> if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL >>> || (dimension && ref2->u.ar.dimen == 0)) >>> { >>> + /* 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. */ >> I think we can be a little be more user friendly with the gfc_notify_std >> error message. >> Something like: >> ALLOCATE without array spec at %L >> ALLOCATE with array bounds determined from SOURCE or MOLD at %L > > I didn't want to mess with the error messages to prevent issues for > translations. So how is the policy on this? > I'm not aware of any policy regarding translations. With a message like: fortran 2008: array specification required ... I don't see how the user can understand that the array specification is _not_ required with fortran 2008, regardless of translations. I'm rather in favour of not having misleading diagnostic, even if correctly translated. -------- >>> *************** gfc_array_init_size (tree descriptor, in >>> *** 5076,5085 **** >>> >>> /* 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); >>> ! >>> gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, >>> gfc_rank_cst[n], se.expr); >>> conv_ubound = se.expr; >>> --- 5087,5111 ---- >>> >>> /* Set upper bound. */ >>> gfc_init_se (&se, NULL); >>> + if (expr3_desc != NULL_TREE) >>> + { >>> + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */ >>> + tmp = fold_build2_loc (input_location, MINUS_EXPR, >>> + gfc_array_index_type, >>> + gfc_conv_descriptor_ubound_get ( >>> + expr3_desc, gfc_rank_cst[n]), >>> + gfc_conv_descriptor_lbound_get ( >>> + expr3_desc, gfc_rank_cst[n])); >>> + se.expr = fold_build2_loc (input_location, PLUS_EXPR, >>> + gfc_array_index_type, tmp, >>> + gfc_index_one_node); >>> + } >>> + 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; >> Your one-based-ness problem was here, wasn't it? > > Correct. > >> I would rather copy directly lbound and ubound from expr3_desc to >> descriptor. > > It was that way in the previous version of the patch, which does *not* work any > longer. When gfc_trans_allocate () is responsible for the creating a temporary > variable for the source=-expression, then it does so using zero based > expressions. > >> If the source has non-one-based bounds, the above would produce wrong >> bounds. > > Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable > created by conv_expr_descriptor, aka zero-based. > here is a counterexample. integer, dimension(:), allocatable :: a, b allocate (a(0:3)) allocate (b, source = a) print *, lbound(a, 1), ubound(a, 1) print *, lbound(b, 1), ubound(b, 1) end output: 0 3 1 4 I think that if you set se.expr with ubound with gfc_conv_descriptor_ubound_get(...) instead of what you do above, and se.expr with gfc_conv_descriptor_lbound_get(...) instead of gfc_index_one_node in the hunk before, it should work. -------- > <snipp> > >>> *************** gfc_trans_allocate (gfc_code * code) >>> *** 5229,5235 **** >>> } >>> else >>> tmp = se.expr; >>> ! if (!code->expr3->mold) >>> expr3 = tmp; >>> else >>> expr3_tmp = tmp; >>> --- 5240,5248 ---- >>> } >>> else >>> tmp = se.expr; >>> ! if (code->ext.alloc.arr_spec_from_expr3) >>> ! expr3_desc = tmp; >>> ! else if (!code->expr3->mold) >>> expr3 = tmp; >>> else >>> expr3_tmp = tmp; >> Couldn't expr3 be reused? >> We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc, >> and (below) inexpr3. :-( > > Of course can we use just two variables for all expressions. I have removed the > expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which > stores which kind the expr3 is, aka unset, source, mold, desc. This makes the > code simpler at some places. > I have thought some more about the code not distinguishing source vs mold. It seems to me that it makes sense to _not_ distinguish, and what you do with e3_is == E3_MOLD seems bogus to me. For example: > @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code) > } > gcc_assert (expr3_esize); > expr3_esize = fold_convert (sizetype, expr3_esize); > + if (e3_is == E3_MOLD) > + { > + /* The expr3 is no longer valid after this point. */ > + expr3 = NULL_TREE; > + e3_is = E3_UNSET; > + } > } > else if (code->ext.alloc.ts.type != BT_UNKNOWN) > { You forget about the descriptor you have just created?!? -------- About e3_is, I'm not very fond of it, and I think it can be replaced using... > + e3_is = expr3 != NULL_TREE ? > + (code->ext.alloc.arr_spec_from_expr3 ? > + E3_DESC > + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) > + : E3_UNSET; > ... the conditions defining it above directly. That is replace e3_is == E3_DESC with code->ext.alloc.arr_spec_from_expr3, etc. -------- > @@ -5035,6 +5036,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; This overrides the rank passed as argument. Instead of this, calculate the correct rank... > @@ -5338,10 +5392,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, ... here. Wasn't it correct already by the way? -------- > @@ -5174,25 +5174,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); > - /* For all "simple" expression just get the descriptor or the > - reference, respectively, depending on the rank of the expr. */ > - if (code->expr3->rank != 0) > + /* For all "simple" expression just get the descriptor > + or the reference, respectively, depending on the > + rank of the expr. */ > + if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) Hum, why this change? Are there cases where arr_spec_from_expr3 is set and code->expr3->rank == 0? And do you really want to call gfc_conv_expr_descriptor in such a case? > 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; > + /* Create a temp variable only for component refs. */ > + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; Why only component refs? > expr3_len = se.string_length; > gfc_add_block_to_block (&block, &se.pre); > gfc_add_block_to_block (&post, &se.post); > } > - /* else expr3 = NULL_TREE set above. */ > + else > + se.expr = NULL_TREE; > } > else > { -------- > diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c > index 9be8a42..3916836 100644 > --- a/gcc/fortran/trans-expr.c > +++ b/gcc/fortran/trans-expr.c > @@ -5328,7 +5328,7 @@ 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) > { > int parm_rank; > tmp = build_fold_indirect_ref_loc (input_location, You don't change it, so don't touch it. > Attached is a new version of the patch. This one fails > allocate_with_source_3.f90 on runtime, where I don't see the issue currently. > May be you have some luck and time. If not I will investigate on Monday. > I haven't looked at it yet. Tomorrow maybe. Thanks for your patience so far. Mikael ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-02 16:52 ` Mikael Morin @ 2015-06-03 15:25 ` Andre Vehreschild 2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild 0 siblings, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-06-03 15:25 UTC (permalink / raw) To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 1516 bytes --] Hi, no, I lost patience with this. Attached is the last version of this patch I will provide. I have changed some things to fix the issues needed for allocate_with_source_3.f90 (now called allocate_with_source_8.f08) to run. The fix implies that source=[type_constructor(...)] generate a zero-bound array, which is not correct according to the standard, but I can't do anything about it you will like. > I have thought some more about the code not distinguishing source vs mold. > It seems to me that it makes sense to _not_ distinguish, and what you do > with e3_is == E3_MOLD seems bogus to me. For example: > > > @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code) > > } > > gcc_assert (expr3_esize); > > expr3_esize = fold_convert (sizetype, expr3_esize); > > + if (e3_is == E3_MOLD) > > + { > > + /* The expr3 is no longer valid after this point. */ > > + expr3 = NULL_TREE; > > + e3_is = E3_UNSET; > > + } > > } > > else if (code->ext.alloc.ts.type != BT_UNKNOWN) > > { > You forget about the descriptor you have just created?!? + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; No, a E3_DESC is set before a E3_MOLD, therefore the reset in the chunk above is not triggered. I can't spend more resources on this. When you see the need of changes, you are welcome to add them. - Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_8.patch --] [-- Type: text/x-patch, Size: 26673 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 905d47c..211c781 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 e615cc6..315170a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6805,7 +6805,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; @@ -7104,13 +7104,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; @@ -7125,7 +7136,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]) @@ -7202,6 +7213,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8fab45..9767e9d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5005,7 +5005,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; @@ -5020,7 +5021,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; @@ -5035,6 +5036,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,7 +5054,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]); + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5076,10 +5084,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; @@ -5249,6 +5261,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*/ @@ -5256,7 +5295,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; @@ -5274,21 +5313,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) { @@ -5324,7 +5366,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; @@ -5338,10 +5381,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) { @@ -7080,6 +7124,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..eb17f2c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4567,6 +4567,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; + bool ulim_copy; gfc_typespec ts; gfc_charlen cl; gfc_expr *e; @@ -4575,6 +4576,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; int arglen; + unsigned int argc; arglist = NULL; retargs = NULL; @@ -4630,10 +4632,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } base_object = NULL_TREE; + ulim_copy = formal == NULL && UNLIMITED_POLY (sym) + && strcmp ("_copy", comp->name) == 0; /* Evaluate the arguments. */ - for (arg = args; arg != NULL; - arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args, argc = 0; arg != NULL; + arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { e = arg->expr; fsym = formal ? formal->sym : NULL; @@ -4735,7 +4739,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + if ((fsym && fsym->attr.value) + || (ulim_copy && (argc == 3 || argc == 4))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -5328,7 +5333,7 @@ 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) { 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 81943b0..43bc34a 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5105,6 +5105,8 @@ gfc_trans_allocate (gfc_code * code) 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; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5117,6 +5119,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; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5156,10 +5159,7 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; @@ -5174,25 +5174,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); - /* For all "simple" expression just get the descriptor or the - reference, respectively, depending on the rank of the expr. */ - if (code->expr3->rank != 0) + /* For all "simple" expression just get the descriptor + or the reference, respectively, depending on the + rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || 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; + /* Create a temp variable only for component refs. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); } - /* else expr3 = NULL_TREE set above. */ + else + se.expr = NULL_TREE; } else { @@ -5212,32 +5213,41 @@ gfc_trans_allocate (gfc_code * code) code->expr3->ts, false, true, false, false); + temp_var_needed = !VAR_P (se.expr); 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. */ - if (!VAR_P (se.expr)) - { - tree var; - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "atmp"); - gfc_add_modify_loc (input_location, &block, var, tmp); - tmp = var; - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; /* When he length of a char array is easily available - here, fix it for future use. */ + here, fix it for future use. */ if (se.string_length) expr3_len = gfc_evaluate_now (se.string_length, &block); } + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); + expr3 = var; + } + else + expr3 = se.expr; + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5252,10 +5262,6 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) - && (VAR_P (expr3_tmp) || !code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5275,9 +5281,7 @@ gfc_trans_allocate (gfc_code * code) { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5338,8 +5342,11 @@ gfc_trans_allocate (gfc_code * code) advantage is, that we get scalarizer support for free, don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () - gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code) } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5490,7 +5503,9 @@ 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, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE)) { /* A scalar or derived type. First compute the size to allocate. @@ -5696,11 +5711,15 @@ gfc_trans_allocate (gfc_code * code) 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)))) + || (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)) { + /* 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; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, @@ -5734,30 +5753,14 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; - 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++) - { - 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); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5839,7 +5842,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 new file mode 100644 index 0000000..86df531 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 new file mode 100644 index 0000000..185681e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 @@ -0,0 +1,111 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + implicit none + type :: cstruct + integer :: i + real :: r(2) + end type cstruct + + 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] )] ) + print *, u(0) + if (any(u(:)%i /= 4) .or. any(abs(u(0)%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) + + 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v9] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-03 15:25 ` Andre Vehreschild @ 2015-06-05 12:04 ` Andre Vehreschild 2015-06-09 5:36 ` Damian Rouson 2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild 0 siblings, 2 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-06-05 12:04 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 762 bytes --] Hi all, attached is the most recent version of the patch. It addresses the standard violation of allocate(foo, source=[bar(something)]), where foo after the allocate was a zero-based array instead of a one-based. Furthermore does this patch fix calling _vptr->_copy () routines, which come without an interface specification leading to pass all arguments by reference. When copying a deferred length string this is hazardous, because a __copy_character_* () routines third and fourth arguments are passed by value. This is fixed by simply counting the actual arguments and using pass by value for third and fourth to _copy routine. Bootstraps and regtests ok on x86_64-linux-gnu/f21. Ok for trunk? - Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_9.clog --] [-- Type: application/octet-stream, Size: 1679 bytes --] gcc/testsuite/ChangeLog: 2015-06-05 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.dg/allocate_with_source_3.f90: Removed check for unimplemented error. * gfortran.dg/allocate_with_source_7.f08: New test. * gfortran.dg/allocate_with_source_8.f08: New test. gcc/fortran/ChangeLog: 2015-065-05 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor, except when the source expression is an array-constructor which is fixed to be one-based. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Special handling for _copy() routine translation, that comes without an interface. Third and fourth argument are now passed by value. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_9.patch --] [-- Type: text/x-patch, Size: 28734 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 905d47c..211c781 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 e615cc6..315170a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6805,7 +6805,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; @@ -7104,13 +7104,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; @@ -7125,7 +7136,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]) @@ -7202,6 +7213,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f552ff9..7494cf9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5001,7 +5001,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, bool e3_is_array_constr) { tree type; tree tmp; @@ -5016,7 +5017,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; @@ -5044,7 +5045,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5072,10 +5084,34 @@ 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) + { + if (e3_is_array_constr) + { + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + se.expr = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + } + else + 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; @@ -5245,6 +5281,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*/ @@ -5252,7 +5315,8 @@ 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, + bool e3_is_array_constr) { tree tmp; tree pointer; @@ -5270,21 +5334,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) { @@ -5320,7 +5387,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; @@ -5334,10 +5402,12 @@ 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, + e3_is_array_constr); if (dimension) { @@ -7076,6 +7146,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..52f1c9a 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, bool); /* 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 5a704cf..f4c4708 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4564,6 +4564,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; + bool ulim_copy; gfc_typespec ts; gfc_charlen cl; gfc_expr *e; @@ -4572,6 +4573,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; int arglen; + unsigned int argc; arglist = NULL; retargs = NULL; @@ -4627,10 +4629,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } base_object = NULL_TREE; + /* For _vprt->_copy () routines no formal symbol is present. Nevertheless + is the third and fourth argument to such a function call a value + denoting the number of elements to copy (i.e., most of the time the + length of a deferred length string). */ + ulim_copy = formal == NULL && UNLIMITED_POLY (sym) + && strcmp ("_copy", comp->name) == 0; /* Evaluate the arguments. */ - for (arg = args; arg != NULL; - arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args, argc = 0; arg != NULL; + arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { e = arg->expr; fsym = formal ? formal->sym : NULL; @@ -4732,7 +4740,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* When no fsym is present, ulim_copy is set and this is a third or + fourth argument, use call-by-value instead of by reference to + hand the length properties to the copy routine (i.e., most of the + time this will be a call to a __copy_character_* routine where the + third and fourth arguments are the lengths of a deferred length + char array). */ + if ((fsym && fsym->attr.value) + || (ulim_copy && (argc == 3 || argc == 4))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -5325,7 +5340,7 @@ 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) { 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 e51cf15..04332f1 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5102,6 +5102,8 @@ gfc_trans_allocate (gfc_code * code) 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; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5114,6 +5116,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; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5153,10 +5156,7 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; @@ -5171,25 +5171,28 @@ 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) + /* For all "simple" expression just get the descriptor + or the reference, respectively, depending on the + rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || 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; + /* Create a temp variable only for component refs to prevent + having to go the full deref-chain each time and to simplfy + computation of array properties. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; expr3_len = se.string_length; gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); } - /* else expr3 = NULL_TREE set above. */ + else + se.expr = NULL_TREE; } else { @@ -5209,32 +5212,41 @@ gfc_trans_allocate (gfc_code * code) code->expr3->ts, false, true, false, false); + temp_var_needed = !VAR_P (se.expr); 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. */ - if (!VAR_P (se.expr)) - { - tree var; - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "atmp"); - gfc_add_modify_loc (input_location, &block, var, tmp); - tmp = var; - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; /* When he length of a char array is easily available - here, fix it for future use. */ + here, fix it for future use. */ if (se.string_length) expr3_len = gfc_evaluate_now (se.string_length, &block); } + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "atmp"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); + expr3 = var; + } + else + expr3 = se.expr; + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5249,10 +5261,6 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) - && (VAR_P (expr3_tmp) || !code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5272,9 +5280,7 @@ gfc_trans_allocate (gfc_code * code) { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5335,8 +5341,11 @@ gfc_trans_allocate (gfc_code * code) advantage is, that we get scalarizer support for free, don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () - gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5388,6 +5397,12 @@ gfc_trans_allocate (gfc_code * code) } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5487,7 +5502,11 @@ 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, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE, + code->expr3 != NULL + && code->expr3->expr_type == EXPR_ARRAY)) { /* A scalar or derived type. First compute the size to allocate. @@ -5693,11 +5712,15 @@ gfc_trans_allocate (gfc_code * code) 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)))) + || (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)) { + /* 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; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, @@ -5731,30 +5754,14 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; - 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++) - { - 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); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5836,7 +5843,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 index f7e0109..93f6edb 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 @@ -21,7 +21,7 @@ program assumed_shape_01 type(cstruct), pointer :: 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" } + allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) call psub(t, u) deallocate (u) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 new file mode 100644 index 0000000..86df531 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 new file mode 100644 index 0000000..b331866 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 @@ -0,0 +1,110 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + implicit none + type :: cstruct + integer :: i + real :: r(2) + end type cstruct + + 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 (any(u(:)%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) + + 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v9] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild @ 2015-06-09 5:36 ` Damian Rouson 2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild 1 sibling, 0 replies; 21+ messages in thread From: Damian Rouson @ 2015-06-09 5:36 UTC (permalink / raw) To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Clune Tom All, I sincerely hope this patch will hit the trunk soon. There are 9 users on the cc list for this bug so it is clearly of considerable user interest. I was recently informed that the following three-line program does not compile: $ cat source-allocation.f90 integer, allocatable :: x(:) allocate(x,source=[1]) end $ gfortran source-allocation.f90 source-allocation.f90:2:11: allocate(x,source=[1]) 1 Error: Array specification required in ALLOCATE statement at (1) $ gfortran --version GNU Fortran (GCC) 6.0.0 20150607 (experimental) I was heartened to find out from the initial bug report that it’s a Fortran 2008 feature, which makes the behavior somewhat understandable, but it’s a fairly simple use case that I would imagine will be used widely. FYI, the above three-line program compiles and executes cleanly with the NAG, Cray, Intel, and Portland Group compilers. ________________________________ Damian Rouson, Ph.D., P.E. Founder & President, Sourcery, Inc. 510-600-2992 (mobile) http://www.sourceryinstitute.org http://rouson.youcanbook.me > On Jun 5, 2015, at 4:04 AM, Andre Vehreschild <vehre@gmx.de> wrote: > > Hi all, > > attached is the most recent version of the patch. It addresses the standard > violation of allocate(foo, source=[bar(something)]), where foo after the > allocate was a zero-based array instead of a one-based. Furthermore does this > patch fix calling _vptr->_copy () routines, which come without an interface > specification leading to pass all arguments by reference. When copying a > deferred length string this is hazardous, because a __copy_character_* () > routines third and fourth arguments are passed by value. This is fixed by > simply counting the actual arguments and using pass by value for third and > fourth to _copy routine. > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > > Ok for trunk? > > - Andre > -- > Andre Vehreschild * Email: vehre ad gmx dot de > <pr44672_9.clog><pr44672_9.patch> ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild 2015-06-09 5:36 ` Damian Rouson @ 2015-06-10 8:59 ` Andre Vehreschild 2015-06-11 22:05 ` Thomas Koenig 1 sibling, 1 reply; 21+ messages in thread From: Andre Vehreschild @ 2015-06-10 8:59 UTC (permalink / raw) To: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 1314 bytes --] Hi all, please find attached an updated version of the patch. This patch simplifies some cases and ensures more straight line code. Furthermore was a bug in the interfacing routine for the _vptr->_copy() routine removed, where not the third and fourth arguments translated to be passed be value but the fourth and fifth (cs start counting at zero...). Bootstraps and regtests fine on x86_64-linux-gnu/f21. Ok for trunk? Regards, Andre On Fri, 5 Jun 2015 13:04:01 +0200 Andre Vehreschild <vehre@gmx.de> wrote: > Hi all, > > attached is the most recent version of the patch. It addresses the standard > violation of allocate(foo, source=[bar(something)]), where foo after the > allocate was a zero-based array instead of a one-based. Furthermore does this > patch fix calling _vptr->_copy () routines, which come without an interface > specification leading to pass all arguments by reference. When copying a > deferred length string this is hazardous, because a __copy_character_* () > routines third and fourth arguments are passed by value. This is fixed by > simply counting the actual arguments and using pass by value for third and > fourth to _copy routine. > > Bootstraps and regtests ok on x86_64-linux-gnu/f21. > > Ok for trunk? > > - Andre -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: pr44672_10.clog --] [-- Type: application/octet-stream, Size: 1679 bytes --] gcc/testsuite/ChangeLog: 2015-06-10 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.dg/allocate_with_source_3.f90: Removed check for unimplemented error. * gfortran.dg/allocate_with_source_7.f08: New test. * gfortran.dg/allocate_with_source_8.f08: New test. gcc/fortran/ChangeLog: 2015-065-10 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor, except when the source expression is an array-constructor which is fixed to be one-based. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Special handling for _copy() routine translation, that comes without an interface. Third and fourth argument are now passed by value. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. [-- Attachment #3: pr44672_10.patch --] [-- Type: text/x-patch, Size: 29306 bytes --] diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 8e4ca42..4b07ddb 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2395,6 +2395,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 52dc109..f365e8f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6805,7 +6805,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; @@ -7104,13 +7104,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; @@ -7125,7 +7136,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]) @@ -7202,6 +7213,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5ea9aec..e9174ae 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4998,7 +4998,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, bool e3_is_array_constr) { tree type; tree tmp; @@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5069,10 +5081,35 @@ 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) + { + if (e3_is_array_constr) + { + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + se.expr = gfc_evaluate_now (tmp, pblock); + } + else + 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; @@ -5242,6 +5279,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*/ @@ -5249,7 +5313,8 @@ 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, + bool e3_is_array_constr) { tree tmp; tree pointer; @@ -5267,21 +5332,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) { @@ -5317,7 +5385,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; @@ -5331,10 +5400,12 @@ 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, + e3_is_array_constr); if (dimension) { @@ -7073,6 +7144,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..52f1c9a 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, bool); /* 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 1c880bc..e75577e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; + bool ulim_copy; gfc_typespec ts; gfc_charlen cl; gfc_expr *e; @@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; int arglen; + unsigned int argc; arglist = NULL; retargs = NULL; @@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } base_object = NULL_TREE; + /* For _vprt->_copy () routines no formal symbol is present. Nevertheless + is the third and fourth argument to such a function call a value + denoting the number of elements to copy (i.e., most of the time the + length of a deferred length string). */ + ulim_copy = formal == NULL && UNLIMITED_POLY (sym) + && strcmp ("_copy", comp->name) == 0; /* Evaluate the arguments. */ - for (arg = args; arg != NULL; - arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args, argc = 0; arg != NULL; + arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { e = arg->expr; fsym = formal ? formal->sym : NULL; @@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* When no fsym is present, ulim_copy is set and this is a third or + fourth argument, use call-by-value instead of by reference to + hand the length properties to the copy routine (i.e., most of the + time this will be a call to a __copy_character_* routine where the + third and fourth arguments are the lengths of a deferred length + char array). */ + if ((fsym && fsym->attr.value) + || (ulim_copy && (argc == 2 || argc == 3))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -5322,7 +5337,7 @@ 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) { 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 a7f39d0..0277d42 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5098,6 +5098,8 @@ gfc_trans_allocate (gfc_code * code) 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; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5110,6 +5112,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; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5149,16 +5152,14 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); + gfc_init_se (&se, NULL); /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ if (code->expr3->expr_type == EXPR_VARIABLE @@ -5167,31 +5168,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); - /* For all "simple" expression just get the descriptor or the - reference, respectively, depending on the rank of the expr. */ - if (code->expr3->rank != 0) + /* Convert expr3 to a tree. For all "simple" expression just + get the descriptor or the reference, respectively, depending + on the rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || 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); + /* Create a temp variable only for component refs to prevent + having to go through the full deref-chain each time and to + simplfy computation of array properties. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; } - /* else expr3 = NULL_TREE set above. */ } else { - /* In all other cases evaluate the expr3 and create a - temporary. */ - gfc_init_se (&se, NULL); + /* In all other cases evaluate the expr3. */ symbol_attribute attr; /* Get the descriptor for all arrays, that are not allocatable or pointer, because the latter are descriptors already. */ @@ -5205,32 +5200,43 @@ gfc_trans_allocate (gfc_code * code) code->expr3->ts, false, true, false, false); - 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. */ - if (!VAR_P (se.expr)) + temp_var_needed = !VAR_P (se.expr); + } + 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. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "source"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) { - tree var; - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "atmp"); - gfc_add_modify_loc (input_location, &block, var, tmp); - tmp = var; + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ + gfc_add_modify_loc (input_location, &block, var, tmp); + expr3 = var; if (se.string_length) + /* Evaluate it assuming that it also is complicated like expr3. */ expr3_len = gfc_evaluate_now (se.string_length, &block); } + else + { + expr3 = se.expr; + expr3_len = se.string_length; + } + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5245,10 +5251,6 @@ gfc_trans_allocate (gfc_code * code) if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) - && (VAR_P (expr3_tmp) || !code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5268,9 +5270,7 @@ gfc_trans_allocate (gfc_code * code) { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5331,8 +5331,11 @@ gfc_trans_allocate (gfc_code * code) advantage is, that we get scalarizer support for free, don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () - gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5384,6 +5387,12 @@ gfc_trans_allocate (gfc_code * code) } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5483,7 +5492,11 @@ 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, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE, + code->expr3 != NULL && e3_is == E3_DESC + && code->expr3->expr_type == EXPR_ARRAY)) { /* A scalar or derived type. First compute the size to allocate. @@ -5689,11 +5702,15 @@ gfc_trans_allocate (gfc_code * code) 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)))) + || (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)) { + /* 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; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, @@ -5727,30 +5744,14 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; - 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++) - { - 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); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5832,7 +5833,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 index f7e0109..93f6edb 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 @@ -21,7 +21,7 @@ program assumed_shape_01 type(cstruct), pointer :: 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" } + allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) call psub(t, u) deallocate (u) diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 new file mode 100644 index 0000000..86df531 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 new file mode 100644 index 0000000..b331866 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 @@ -0,0 +1,110 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + implicit none + type :: cstruct + integer :: i + real :: r(2) + end type cstruct + + 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 (any(u(:)%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) + + 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild @ 2015-06-11 22:05 ` Thomas Koenig 2015-06-12 8:00 ` Andre Vehreschild 2015-06-15 10:43 ` Andre Vehreschild 0 siblings, 2 replies; 21+ messages in thread From: Thomas Koenig @ 2015-06-11 22:05 UTC (permalink / raw) To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML Hi Andre, > please find attached an updated version of the patch. This patch simplifies > some cases and ensures more straight line code. Furthermore was a bug in the > interfacing routine for the _vptr->_copy() routine removed, where not the third > and fourth arguments translated to be passed be value but the fourth and fifth > (cs start counting at zero...). > > Bootstraps and regtests fine on x86_64-linux-gnu/f21. > > Ok for trunk? Following the discussions, and looking through the patch, I would say this patch is in pretty good shape (and quite impressive, too). My vote would be to commit as is, unless something important comes up, and fix smaller problems and possible corner cases afterwards, if any exist. However, I am not really deep into these aspects of the compiler, and I would still like to leave some time for others to comment if they think this is appropriate. So, OK to commit in two days unless there are objections. Thanks for the patch! Thomas ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-11 22:05 ` Thomas Koenig @ 2015-06-12 8:00 ` Andre Vehreschild 2015-06-15 10:43 ` Andre Vehreschild 1 sibling, 0 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-06-12 8:00 UTC (permalink / raw) To: Thomas Koenig; +Cc: GCC-Patches-ML, GCC-Fortran-ML Hi Thomas, thanks for the review and valuing my effort. I am on travel over the weekend, i.e., I will commit the job earliest on Monday giving objections a bit more time. Regards and thanks, Andre On Thu, 11 Jun 2015 23:59:48 +0200 Thomas Koenig <tkoenig@netcologne.de> wrote: > Hi Andre, > > > please find attached an updated version of the patch. This patch simplifies > > some cases and ensures more straight line code. Furthermore was a bug in the > > interfacing routine for the _vptr->_copy() routine removed, where not the > > third and fourth arguments translated to be passed be value but the fourth > > and fifth (cs start counting at zero...). > > > > Bootstraps and regtests fine on x86_64-linux-gnu/f21. > > > > Ok for trunk? > > Following the discussions, and looking through the patch, I would say > this patch is in pretty good shape (and quite impressive, too). > > My vote would be to commit as is, unless something important comes up, > and fix smaller problems and possible corner cases afterwards, if any > exist. However, I am not really deep into these aspects of the > compiler, and I would still like to leave some time for others to > comment if they think this is appropriate. > > So, OK to commit in two days unless there are objections. > > Thanks for the patch! > > Thomas > -- Andre Vehreschild * Email: vehre ad gmx dot de ^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec 2015-06-11 22:05 ` Thomas Koenig 2015-06-12 8:00 ` Andre Vehreschild @ 2015-06-15 10:43 ` Andre Vehreschild 1 sibling, 0 replies; 21+ messages in thread From: Andre Vehreschild @ 2015-06-15 10:43 UTC (permalink / raw) To: Thomas Koenig; +Cc: GCC-Patches-ML, GCC-Fortran-ML [-- Attachment #1: Type: text/plain, Size: 1294 bytes --] Hi Thomas, hi all, I got no objections so far, therefore commited as r224477. Thanks for the review. Regards, Andre On Thu, 11 Jun 2015 23:59:48 +0200 Thomas Koenig <tkoenig@netcologne.de> wrote: > Hi Andre, > > > please find attached an updated version of the patch. This patch simplifies > > some cases and ensures more straight line code. Furthermore was a bug in the > > interfacing routine for the _vptr->_copy() routine removed, where not the > > third and fourth arguments translated to be passed be value but the fourth > > and fifth (cs start counting at zero...). > > > > Bootstraps and regtests fine on x86_64-linux-gnu/f21. > > > > Ok for trunk? > > Following the discussions, and looking through the patch, I would say > this patch is in pretty good shape (and quite impressive, too). > > My vote would be to commit as is, unless something important comes up, > and fix smaller problems and possible corner cases afterwards, if any > exist. However, I am not really deep into these aspects of the > compiler, and I would still like to leave some time for others to > comment if they think this is appropriate. > > So, OK to commit in two days unless there are objections. > > Thanks for the patch! > > Thomas > -- Andre Vehreschild * Email: vehre ad gmx dot de [-- Attachment #2: submit.diff --] [-- Type: text/x-patch, Size: 31037 bytes --] Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 224476) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,35 @@ +2015-06-15 Andre Vehreschild <vehre@gmx.de> + + PR fortran/44672 + PR fortran/45440 + PR fortran/57307 + * gfortran.h: Extend gfc_code.ext.alloc to carry a + flag indicating that the array specification has to be + taken from expr3. + * resolve.c (resolve_allocate_expr): Add F2008 notify + and flag indicating source driven array spec. + (resolve_allocate_deallocate): Check for source driven + array spec, when array to allocate has no explicit + array spec. + * trans-array.c (gfc_array_init_size): Get lower and + upper bound from a tree array descriptor, except when + the source expression is an array-constructor which is + fixed to be one-based. + (retrieve_last_ref): Extracted from gfc_array_allocate(). + (gfc_array_allocate): Enable allocate(array, source= + array_expression) as specified by F2008:C633. + (gfc_conv_expr_descriptor): Add class tree expression + into the saved descriptor for class arrays. + * trans-array.h: Add temporary array descriptor to + gfc_array_allocate (). + * trans-expr.c (gfc_conv_procedure_call): Special handling + for _copy() routine translation, that comes without an + interface. Third and fourth argument are now passed by value. + * trans-stmt.c (gfc_trans_allocate): Get expr3 array + descriptor for temporary arrays to allow allocate(array, + source = array_expression) for array without array + specification. + 2015-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> * intrinsic.texi: Change \leq to < in descrition of imaginary Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 224476) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -2395,6 +2395,9 @@ { 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; Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 224476) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -6805,7 +6805,7 @@ 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; @@ -7104,13 +7104,24 @@ 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; @@ -7125,7 +7136,7 @@ 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]) @@ -7202,6 +7213,7 @@ return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7376,8 +7388,16 @@ 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; + } } else { Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 224476) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -4998,7 +4998,8 @@ 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, bool e3_is_array_constr) { tree type; tree tmp; @@ -5041,7 +5042,18 @@ /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5069,10 +5081,35 @@ /* 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) + { + if (e3_is_array_constr) + { + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + se.expr = gfc_evaluate_now (tmp, pblock); + } + else + 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; @@ -5242,6 +5279,33 @@ } +/* 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*/ @@ -5249,7 +5313,8 @@ 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, + bool e3_is_array_constr) { tree tmp; tree pointer; @@ -5267,22 +5332,25 @@ 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; + + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + alloc_w_e3_arr_spec = true; } - if (ref == NULL || ref->type != REF_ARRAY) - return false; - if (!prev_ref) { allocatable = expr->symtree->n.sym->attr.allocatable; @@ -5317,7 +5385,8 @@ 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; @@ -5331,10 +5400,12 @@ 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, + e3_is_array_constr); if (dimension) { @@ -7073,6 +7144,16 @@ 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. */ Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (Revision 224476) +++ gcc/fortran/trans-array.h (Arbeitskopie) @@ -24,7 +24,7 @@ /* 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, bool); /* 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 *, Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 224476) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -4561,6 +4561,7 @@ int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; + bool ulim_copy; gfc_typespec ts; gfc_charlen cl; gfc_expr *e; @@ -4569,6 +4570,7 @@ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; int arglen; + unsigned int argc; arglist = NULL; retargs = NULL; @@ -4624,10 +4626,16 @@ } base_object = NULL_TREE; + /* For _vprt->_copy () routines no formal symbol is present. Nevertheless + is the third and fourth argument to such a function call a value + denoting the number of elements to copy (i.e., most of the time the + length of a deferred length string). */ + ulim_copy = formal == NULL && UNLIMITED_POLY (sym) + && strcmp ("_copy", comp->name) == 0; /* Evaluate the arguments. */ - for (arg = args; arg != NULL; - arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args, argc = 0; arg != NULL; + arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { e = arg->expr; fsym = formal ? formal->sym : NULL; @@ -4729,7 +4737,14 @@ gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* When no fsym is present, ulim_copy is set and this is a third or + fourth argument, use call-by-value instead of by reference to + hand the length properties to the copy routine (i.e., most of the + time this will be a call to a __copy_character_* routine where the + third and fourth arguments are the lengths of a deferred length + char array). */ + if ((fsym && fsym->attr.value) + || (ulim_copy && (argc == 2 || argc == 3))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -5322,7 +5337,7 @@ 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) { int parm_rank; tmp = build_fold_indirect_ref_loc (input_location, Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 224476) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -5098,6 +5098,8 @@ 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; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; @@ -5110,6 +5112,7 @@ 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; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5149,10 +5152,7 @@ expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; @@ -5159,6 +5159,7 @@ al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); + gfc_init_se (&se, NULL); /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ if (code->expr3->expr_type == EXPR_VARIABLE @@ -5167,31 +5168,25 @@ { 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) + /* Convert expr3 to a tree. For all "simple" expression just + get the descriptor or the reference, respectively, depending + on the rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || 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); + /* Create a temp variable only for component refs to prevent + having to go through the full deref-chain each time and to + simplfy computation of array properties. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; } - /* else expr3 = NULL_TREE set above. */ } else { - /* In all other cases evaluate the expr3 and create a - temporary. */ - gfc_init_se (&se, NULL); + /* In all other cases evaluate the expr3. */ symbol_attribute attr; /* Get the descriptor for all arrays, that are not allocatable or pointer, because the latter are descriptors already. */ @@ -5205,45 +5200,55 @@ code->expr3->ts, false, true, false, false); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); + temp_var_needed = !VAR_P (se.expr); + } + 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. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "source"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); - /* Prevent aliasing, i.e., se.expr may be already a - variable declaration. */ - if (!VAR_P (se.expr)) + /* Deallocate any allocatable components after all the allocations + and assignments of expr3 have been completed. */ + if (code->expr3->ts.type == BT_DERIVED + && code->expr3->rank == 0 + && code->expr3->ts.u.derived->attr.alloc_comp) { - tree var; - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "source"); - gfc_add_modify_loc (input_location, &block, var, tmp); + tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, + var, 0); + gfc_add_expr_to_block (&post, tmp); + } - /* Deallocate any allocatable components after all the allocations - and assignments of expr3 have been completed. */ - if (code->expr3->ts.type == BT_DERIVED - && code->expr3->rank == 0 - && code->expr3->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, - var, 0); - gfc_add_expr_to_block (&post, tmp); - } - - tmp = var; - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ + expr3 = var; if (se.string_length) + /* Evaluate it assuming that it also is complicated like expr3. */ expr3_len = gfc_evaluate_now (se.string_length, &block); } + else + { + expr3 = se.expr; + expr3_len = se.string_length; + } + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5258,10 +5263,6 @@ if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp)) - && (VAR_P (expr3_tmp) || !code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5281,9 +5282,7 @@ { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5344,8 +5343,11 @@ advantage is, that we get scalarizer support for free, don't have to take care about scalar to array treatment and will benefit of every enhancements gfc_trans_assignment () - gets. */ - if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current namespace to prevent accidently modifying @@ -5397,6 +5399,12 @@ } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5496,7 +5504,11 @@ else tmp = expr3_esize; if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, code->expr3)) + label_finish, tmp, &nelems, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE, + code->expr3 != NULL && e3_is == E3_DESC + && code->expr3->expr_type == EXPR_ARRAY)) { /* A scalar or derived type. First compute the size to allocate. @@ -5702,11 +5714,15 @@ 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)))) + || (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)) { + /* 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; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, @@ -5740,30 +5756,14 @@ if (dataref && dataref->u.c.component->as) { - int dim; - 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++) - { - 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); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5845,7 +5845,7 @@ gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 224476) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,13 @@ +2015-06-15 Andre Vehreschild <vehre@gmx.de> + + PR fortran/44672 + PR fortran/45440 + PR fortran/57307 + * gfortran.dg/allocate_with_source_3.f90: Removed check for + unimplemented error. + * gfortran.dg/allocate_with_source_7.f08: New test. + * gfortran.dg/allocate_with_source_8.f08: New test. + 2015-06-13 Patrick Palka <ppalka@gcc.gnu.org> PR c++/65168 Index: gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 (Revision 224476) +++ gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 (Arbeitskopie) @@ -21,7 +21,7 @@ type(cstruct), pointer :: 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" } + allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) call psub(t, u) deallocate (u) Index: gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 (Revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 (Arbeitskopie) @@ -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 <burnus@gcc.gnu.org> +! Antony Lewis <antony@cosmologist.info> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +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 + Index: gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 (Revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 (Arbeitskopie) @@ -0,0 +1,110 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + implicit none + type :: cstruct + integer :: i + real :: r(2) + end type cstruct + + 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 (any(u(:)%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) + + 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 ^ permalink raw reply [flat|nested] 21+ messages in thread
end of thread, other threads:[~2015-06-15 10:26 UTC | newest] Thread overview: 21+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2015-03-30 17:48 [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec Andre Vehreschild 2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild 2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild 2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild 2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild 2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild 2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild 2015-05-22 10:24 ` Ping: " Andre Vehreschild 2015-05-25 19:35 ` Mikael Morin 2015-05-28 15:48 ` Andre Vehreschild 2015-05-28 18:42 ` Mikael Morin 2015-05-29 12:41 ` Andre Vehreschild 2015-05-30 4:23 ` Thomas Koenig 2015-06-02 16:52 ` Mikael Morin 2015-06-03 15:25 ` Andre Vehreschild 2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild 2015-06-09 5:36 ` Damian Rouson 2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild 2015-06-11 22:05 ` Thomas Koenig 2015-06-12 8:00 ` Andre Vehreschild 2015-06-15 10:43 ` Andre Vehreschild
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).