From: Andre Vehreschild Date: Mon, 15 Jun 2015 10:08:04 +0000 (+0200) Subject: re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1792349b0bd2702c642bb4f57686ecf32810810f;p=gcc.git re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec) gcc/testsuite/ChangeLog: 2015-06-15 Andre Vehreschild 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-06-15 Andre Vehreschild 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. From-SVN: r224477 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 025214bd5c5..5ede14dbc34 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,35 @@ +2015-06-15 Andre Vehreschild + + 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 * intrinsic.texi: Change \leq to < in descrition of imaginary diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 8e4ca42642b..4b07ddb13f4 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 52dc10949e6..f365e8ff75c 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 5ea9aecf443..e9174aebd1e 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 2155b58ba8e..52f1c9aef89 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 e3f49f59703..77d2cda0288 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 69750dfa010..6772a3cf809 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,45 +5200,55 @@ 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), "source"); - gfc_add_modify_loc (input_location, &block, var, 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); - } + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); - tmp = var; + /* 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); } - 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 @@ 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); @@ -5281,9 +5282,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); @@ -5344,8 +5343,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 @@ -5397,6 +5399,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) { @@ -5496,7 +5504,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. @@ -5702,11 +5714,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, @@ -5740,30 +5756,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) { @@ -5845,7 +5845,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/ChangeLog b/gcc/testsuite/ChangeLog index b9b96e7e1b3..0d574821068 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2015-06-15 Andre Vehreschild + + 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 PR c++/65168 diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 index f7e010948ac..93f6edb06d1 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 00000000000..86df5319f25 --- /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 +! Antony Lewis +! Andre Vehreschild +! + +program allocate_with_source_6 + + type P + class(*), allocatable :: X(:,:) + end type + + type t + end type t + + type(t), allocatable :: a(:), b, c(:) + integer :: num_params_used = 6 + integer, allocatable :: m(:) + + allocate(b,c(5)) + allocate(a(5), source=b) + deallocate(a) + allocate(a, source=c) + allocate(m, source=[(I, I=1, num_params_used)]) + if (any(m /= [(I, I=1, num_params_used)])) call abort() + deallocate(a,b,m) + call testArrays() + +contains + subroutine testArrays() + type L + class(*), allocatable :: v(:) + end type + Type(P) Y + type(L) o + real arr(3,5) + real, allocatable :: v(:) + + arr = 5 + allocate(Y%X, source=arr) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) & + call abort() + class default + call abort() + end select + deallocate(Y%X) + + allocate(Y%X, source=arr(2:3,3:4)) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [4]) /= [5,5,5,5])) & + call abort() + class default + call abort() + end select + deallocate(Y%X) + + allocate(o%v, source=arr(2,3:4)) + select type (R => o%v) + type is (real) + if (any(R /= [5,5])) & + call abort() + class default + call abort() + end select + deallocate(o%v) + + allocate(v, source=arr(2,1:5)) + if (any(v /= [5,5,5,5,5])) call abort() + deallocate(v) + end subroutine testArrays +end + 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 00000000000..b3318669ddf --- /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