Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 117054) --- gcc/fortran/interface.c (working copy) *************** gfc_compare_derived_types (gfc_symbol * *** 374,379 **** --- 374,382 ---- if (dt1->dimension != dt2->dimension) return 0; + if (dt1->allocatable != dt2->allocatable) + return 0; + if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) return 0; Index: gcc/fortran/intrinsic.c =================================================================== *** gcc/fortran/intrinsic.c (revision 117054) --- gcc/fortran/intrinsic.c (working copy) *************** add_subroutines (void) *** 2391,2396 **** --- 2391,2401 ---- length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL, trim_name, BT_LOGICAL, dl, OPTIONAL); + add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003, + gfc_check_move_alloc, NULL, NULL, + f, BT_UNKNOWN, 0, REQUIRED, + t, BT_UNKNOWN, 0, REQUIRED); + add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits, f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED, Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 117054) --- gcc/fortran/trans-array.c (working copy) *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 3236,3267 **** tree size; gfc_expr **lower; gfc_expr **upper; ! gfc_ref *ref; ! int allocatable_array; ! int must_be_pointer; ref = expr->ref; - /* In Fortran 95, components can only contain pointers, so that, - in ALLOCATE (foo%bar(2)), bar must be a pointer component. - We test this by checking for ref->next. - An implementation of TR 15581 would need to change this. */ - - if (ref) - must_be_pointer = ref->next != NULL; - else - must_be_pointer = 0; - /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); ref = ref->next; } if (ref == NULL || ref->type != REF_ARRAY) return false; /* Figure out the size of the array. */ switch (ref->u.ar.type) { --- 3236,3262 ---- tree size; gfc_expr **lower; gfc_expr **upper; ! gfc_ref *ref, *prev_ref = NULL; ! bool allocatable_array; ref = expr->ref; /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); + prev_ref = ref; ref = ref->next; } if (ref == NULL || ref->type != REF_ARRAY) return false; + if (!prev_ref) + allocatable_array = expr->symtree->n.sym->attr.allocatable; + else + allocatable_array = prev_ref->u.c.component->allocatable; + /* Figure out the size of the array. */ switch (ref->u.ar.type) { *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 3294,3304 **** tmp = gfc_conv_descriptor_data_addr (se->expr); pointer = gfc_evaluate_now (tmp, &se->pre); - if (must_be_pointer) - allocatable_array = 0; - else - allocatable_array = expr->symtree->n.sym->attr.allocatable; - if (TYPE_PRECISION (gfc_array_index_type) == 32) { if (allocatable_array) --- 3289,3294 ---- *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 3325,3330 **** --- 3315,3328 ---- tmp = gfc_conv_descriptor_offset (se->expr); gfc_add_modify_expr (&se->pre, tmp, offset); + if (expr->ts.type == BT_DERIVED + && expr->ts.derived->attr.alloc_comp) + { + tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr, + ref->u.ar.as->rank); + gfc_add_expr_to_block (&se->pre, tmp); + } + return true; } *************** gfc_conv_array_initializer (tree type, g *** 3465,3470 **** --- 3463,3471 ---- } break; + case EXPR_NULL: + return gfc_build_null_descriptor (type); + default: gcc_unreachable (); } *************** gfc_conv_array_parameter (gfc_se * se, g *** 4547,4552 **** --- 4548,4564 ---- se->want_pointer = 1; gfc_conv_expr_descriptor (se, expr, ss); + /* Deallocate the allocatable components of structures that are + not variable. */ + if (expr->ts.type == BT_DERIVED + && expr->ts.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) + { + tmp = build_fold_indirect_ref (se->expr); + tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank); + gfc_add_expr_to_block (&se->post, tmp); + } + if (g77) { desc = se->expr; *************** tree *** 4595,4619 **** gfc_trans_dealloc_allocated (tree descriptor) { tree tmp; ! tree deallocate; stmtblock_t block; gfc_start_block (&block); - deallocate = gfc_array_deallocate (descriptor, null_pointer_node); ! tmp = gfc_conv_descriptor_data_get (descriptor); ! tmp = build2 (NE_EXPR, boolean_type_node, tmp, ! build_int_cst (TREE_TYPE (tmp), 0)); ! tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ()); gfc_add_expr_to_block (&block, tmp); tmp = gfc_finish_block (&block); ! return tmp; } ! /* NULLIFY an allocatable/pointer array on function entry, free it on exit. */ tree gfc_trans_deferred_array (gfc_symbol * sym, tree body) --- 4607,4928 ---- gfc_trans_dealloc_allocated (tree descriptor) { tree tmp; ! tree ptr; ! tree var; stmtblock_t block; gfc_start_block (&block); ! tmp = gfc_conv_descriptor_data_addr (descriptor); ! var = gfc_evaluate_now (tmp, &block); ! tmp = gfc_create_var (gfc_array_index_type, NULL); ! ptr = build_fold_addr_expr (tmp); ! ! /* Call array_deallocate with an int* present in the second argument. ! Although it is ignored here, it's presence ensures that arrays that ! are already deallocated are ignored. */ ! tmp = gfc_chainon_list (NULL_TREE, var); ! tmp = gfc_chainon_list (tmp, ptr); ! tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp); gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); + } + + /* This helper function calculates the size in words of a full array. */ + + static tree + get_full_array_size (stmtblock_t *block, tree decl, int rank) + { + tree idx; + tree nelems; + tree tmp; + idx = gfc_rank_cst[rank - 1]; + nelems = gfc_conv_descriptor_ubound (decl, idx); + tmp = gfc_conv_descriptor_lbound (decl, idx); + tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp); + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, block); + + nelems = gfc_conv_descriptor_stride (decl, idx); + tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp); + return gfc_evaluate_now (tmp, block); + } + + + /* Allocate dest to the same size as src, and copy src -> dest. */ + + tree + gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) + { + tree tmp; + tree size; + tree nelems; + tree args; + tree null_cond; + tree null_data; + stmtblock_t block; + + /* If the source is null, set the destination to null. */ + gfc_init_block (&block); + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + + nelems = get_full_array_size (&block, src, rank); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + + /* Allocate memory to the destination. */ + tmp = gfc_chainon_list (NULL_TREE, size); + if (gfc_index_integer_kind == 4) + tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp); + else if (gfc_index_integer_kind == 8) + tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp); + else + gcc_unreachable (); + tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)), + tmp)); + gfc_conv_descriptor_data_set (&block, dest, tmp); + + /* We know the temporary and the value will be the same length, + so can use memcpy. */ + tmp = gfc_conv_descriptor_data_get (dest); + args = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_conv_descriptor_data_get (src); + args = gfc_chainon_list (args, tmp); + args = gfc_chainon_list (args, size); + tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = build_function_call_expr (tmp, args); + gfc_add_expr_to_block (&block, tmp); tmp = gfc_finish_block (&block); ! /* Null the destination if the source is null; otherwise do ! the allocate and copy. */ ! null_cond = gfc_conv_descriptor_data_get (src); ! null_cond = convert (pvoid_type_node, null_cond); ! null_cond = build2 (NE_EXPR, boolean_type_node, null_cond, ! null_pointer_node); ! return build3_v (COND_EXPR, null_cond, tmp, null_data); ! } ! ! ! /* Recursively traverse an object of derived type, generating code to ! deallocate, nullify or copy allocatable components. This is the work horse ! function for the functions named in this enum. */ ! ! enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP}; ! ! static tree ! structure_alloc_comps (gfc_symbol * der_type, tree decl, ! tree dest, int rank, int purpose) ! { ! gfc_component *c; ! gfc_loopinfo loop; ! stmtblock_t fnblock; ! stmtblock_t loopbody; ! tree tmp; ! tree comp; ! tree dcmp; ! tree nelems; ! tree index; ! tree var; ! tree cdecl; ! tree ctype; ! tree vref, dref; ! tree null_cond = NULL_TREE; ! ! gfc_init_block (&fnblock); ! ! /* If this an array of derived types with allocatable components ! build a loop and recursively call this function. */ ! if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE ! || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) ! { ! tmp = gfc_conv_array_data (decl); ! var = build_fold_indirect_ref (tmp); ! ! /* Get the number of elements - 1 and set the counter. */ ! if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) ! { ! /* Use the descriptor for an allocatable array. Since this ! is a full array reference, we only need the descriptor ! information from dimension = rank. */ ! tmp = get_full_array_size (&fnblock, decl, rank); ! tmp = build2 (MINUS_EXPR, gfc_array_index_type, ! tmp, gfc_index_one_node); ! ! null_cond = gfc_conv_descriptor_data_get (decl); ! null_cond = build2 (NE_EXPR, boolean_type_node, null_cond, ! build_int_cst (TREE_TYPE (tmp), 0)); ! } ! else ! { ! /* Otherwise use the TYPE_DOMAIN information. */ ! tmp = array_type_nelts (TREE_TYPE (decl)); ! tmp = fold_convert (gfc_array_index_type, tmp); ! } ! ! /* Remember that this is, in fact, the no. of elements - 1. */ ! nelems = gfc_evaluate_now (tmp, &fnblock); ! index = gfc_create_var (gfc_array_index_type, "S"); ! ! /* Build the body of the loop. */ ! gfc_init_block (&loopbody); ! ! vref = gfc_build_array_ref (var, index); ! ! if (purpose == COPY_ALLOC_COMP) ! { ! tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); ! gfc_add_expr_to_block (&fnblock, tmp); ! ! tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest)); ! dref = gfc_build_array_ref (tmp, index); ! tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); ! } ! else ! tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose); ! ! gfc_add_expr_to_block (&loopbody, tmp); ! ! /* Build the loop and return. */ ! gfc_init_loopinfo (&loop); ! loop.dimen = 1; ! loop.from[0] = gfc_index_zero_node; ! loop.loopvar[0] = index; ! loop.to[0] = nelems; ! gfc_trans_scalarizing_loops (&loop, &loopbody); ! gfc_add_block_to_block (&fnblock, &loop.pre); ! ! tmp = gfc_finish_block (&fnblock); ! if (null_cond != NULL_TREE) ! tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ()); ! ! return tmp; ! } ! ! /* Otherwise, act on the components or recursively call self to ! act on a chain of components. */ ! for (c = der_type->components; c; c = c->next) ! { ! bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED) ! && c->ts.derived->attr.alloc_comp; ! cdecl = c->backend_decl; ! ctype = TREE_TYPE (cdecl); ! ! switch (purpose) ! { ! case DEALLOCATE_ALLOC_COMP: ! /* Do not deallocate the components of ultimate pointer ! components. */ ! if (cmp_has_alloc_comps && !c->pointer) ! { ! comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); ! rank = c->as ? c->as->rank : 0; ! tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, ! rank, purpose); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! ! if (c->allocatable) ! { ! comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); ! tmp = gfc_trans_dealloc_allocated (comp); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! break; ! ! case NULLIFY_ALLOC_COMP: ! if (c->pointer) ! continue; ! else if (c->allocatable) ! { ! comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); ! gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); ! } ! else if (cmp_has_alloc_comps) ! { ! comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); ! rank = c->as ? c->as->rank : 0; ! tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, ! rank, purpose); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! break; ! ! case COPY_ALLOC_COMP: ! if (c->pointer) ! continue; ! ! /* We need source and destination components. */ ! comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); ! dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE); ! dcmp = fold_convert (TREE_TYPE (comp), dcmp); ! ! if (c->allocatable && !cmp_has_alloc_comps) ! { ! tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! ! if (cmp_has_alloc_comps) ! { ! rank = c->as ? c->as->rank : 0; ! tmp = fold_convert (TREE_TYPE (dcmp), comp); ! gfc_add_modify_expr (&fnblock, dcmp, tmp); ! tmp = structure_alloc_comps (c->ts.derived, comp, dcmp, ! rank, purpose); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! break; ! ! default: ! gcc_unreachable (); ! break; ! } ! } ! ! return gfc_finish_block (&fnblock); ! } ! ! /* Recursively traverse an object of derived type, generating code to ! nullify allocatable components. */ ! ! tree ! gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank) ! { ! return structure_alloc_comps (der_type, decl, NULL_TREE, rank, ! NULLIFY_ALLOC_COMP); } ! /* Recursively traverse an object of derived type, generating code to ! deallocate allocatable components. */ ! ! tree ! gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) ! { ! return structure_alloc_comps (der_type, decl, NULL_TREE, rank, ! DEALLOCATE_ALLOC_COMP); ! } ! ! ! /* Recursively traverse an object of derived type, generating code to ! copy its allocatable components. */ ! ! tree ! gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) ! { ! return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP); ! } ! ! ! /* NULLIFY an allocatable/pointer array on function entry, free it on exit. ! Do likewise, recursively if necessary, with the allocatable components of ! derived types. */ tree gfc_trans_deferred_array (gfc_symbol * sym, tree body) *************** gfc_trans_deferred_array (gfc_symbol * s *** 4623,4638 **** tree descriptor; stmtblock_t fnblock; locus loc; /* Make sure the frontend gets these right. */ ! if (!(sym->attr.pointer || sym->attr.allocatable)) ! fatal_error ! ("Possible frontend bug: Deferred array size without pointer or allocatable attribute."); gfc_init_block (&fnblock); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL ! || TREE_CODE (sym->backend_decl) == PARM_DECL); if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) --- 4932,4953 ---- tree descriptor; stmtblock_t fnblock; locus loc; + int rank; + bool sym_has_alloc_comp; + + sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) + && sym->ts.derived->attr.alloc_comp; /* Make sure the frontend gets these right. */ ! if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) ! fatal_error ("Possible frontend bug: Deferred array size without pointer, " ! "allocatable attribute or derived type without allocatable " ! "components."); gfc_init_block (&fnblock); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL ! || TREE_CODE (sym->backend_decl) == PARM_DECL); if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) *************** gfc_trans_deferred_array (gfc_symbol * s *** 4653,4659 **** gfc_set_backend_locus (&sym->declared_at); descriptor = sym->backend_decl; ! if (TREE_STATIC (descriptor)) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); --- 4968,4977 ---- gfc_set_backend_locus (&sym->declared_at); descriptor = sym->backend_decl; ! /* Although static, derived types with deafult initializers and ! allocatable components must not be nulled wholesale; instead they ! are treated component by component. */ ! if (TREE_STATIC (descriptor) && !sym_has_alloc_comp) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); *************** gfc_trans_deferred_array (gfc_symbol * s *** 4662,4683 **** /* Get the descriptor type. */ type = TREE_TYPE (sym->backend_decl); ! if (!GFC_DESCRIPTOR_TYPE_P (type)) { /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref (sym->backend_decl); type = TREE_TYPE (descriptor); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); } ! /* NULLIFY the data pointer. */ ! gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); gfc_add_expr_to_block (&fnblock, body); gfc_set_backend_locus (&loc); ! /* Allocatable arrays need to be freed when they go out of scope. */ if (sym->attr.allocatable) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); --- 4980,5019 ---- /* Get the descriptor type. */ type = TREE_TYPE (sym->backend_decl); ! ! if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) ! { ! rank = sym->as ? sym->as->rank : 0; ! tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! else if (!GFC_DESCRIPTOR_TYPE_P (type)) { /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref (sym->backend_decl); type = TREE_TYPE (descriptor); } ! /* NULLIFY the data pointer. */ ! if (GFC_DESCRIPTOR_TYPE_P (type)) ! gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); gfc_add_expr_to_block (&fnblock, body); gfc_set_backend_locus (&loc); ! ! /* Allocatable arrays need to be freed when they go out of scope. ! The allocatable components of pointers must not be touched. */ ! if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) ! && !sym->attr.pointer) ! { ! int rank; ! rank = sym->as ? sym->as->rank : 0; ! tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank); ! gfc_add_expr_to_block (&fnblock, tmp); ! } ! if (sym->attr.allocatable) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 117054) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_aliased_arg (gfc_se * parmse, g *** 1701,1707 **** if (intent != INTENT_OUT) { ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); --- 1701,1707 ---- if (intent != INTENT_OUT) { ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); *************** gfc_conv_aliased_arg (gfc_se * parmse, g *** 1792,1798 **** gcc_assert (lse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ --- 1792,1798 ---- gcc_assert (lse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ *************** gfc_conv_function_call (gfc_se * se, gfc *** 1864,1869 **** --- 1864,1870 ---- gfc_ss *argss; gfc_ss_info *info; int byref; + int parm_kind; tree type; tree var; tree len; *************** gfc_conv_function_call (gfc_se * se, gfc *** 1877,1882 **** --- 1878,1884 ---- gfc_expr *e; gfc_symbol *fsym; stmtblock_t post; + enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; arglist = NULL_TREE; retargs = NULL_TREE; *************** gfc_conv_function_call (gfc_se * se, gfc *** 1919,1924 **** --- 1921,1927 ---- { e = arg->expr; fsym = formal ? formal->sym : NULL; + parm_kind = MISSING; if (e == NULL) { *************** gfc_conv_function_call (gfc_se * se, gfc *** 1947,1952 **** --- 1950,1956 ---- /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); gfc_conv_expr_reference (&parmse, e); + parm_kind = ELEMENTAL; } else { *************** gfc_conv_function_call (gfc_se * se, gfc *** 1957,1968 **** --- 1961,1974 ---- if (argss == gfc_ss_terminator) { gfc_conv_expr_reference (&parmse, e); + parm_kind = SCALAR; if (fsym && fsym->attr.pointer && e->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains this level of indirection. */ + parm_kind = SCALAR_POINTER; parmse.expr = build_fold_addr_expr (parmse.expr); } } *************** gfc_conv_function_call (gfc_se * se, gfc *** 2029,2035 **** gfc_add_expr_to_block (&se->pre, tmp); } ! if (fsym && fsym->ts.type == BT_CHARACTER && parmse.string_length == NULL_TREE && e->ts.type == BT_PROCEDURE && e->symtree->n.sym->ts.type == BT_CHARACTER --- 2035,2041 ---- gfc_add_expr_to_block (&se->pre, tmp); } ! if (e && fsym && fsym->ts.type == BT_CHARACTER && parmse.string_length == NULL_TREE && e->ts.type == BT_PROCEDURE && e->symtree->n.sym->ts.type == BT_CHARACTER *************** gfc_conv_function_call (gfc_se * se, gfc *** 2039,2044 **** --- 2045,2093 ---- parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl; } + /* Allocated allocatable components of derived types must be + deallocated for INTENT(OUT) dummy arguments and non-variable + scalars. Non-variable arrays are dealt with in trans-array.c + (gfc_conv_array_parameter). */ + if (e && e->ts.type == BT_DERIVED + && e->ts.derived->attr.alloc_comp + && ((formal && formal->sym->attr.intent == INTENT_OUT) + || + (e->expr_type != EXPR_VARIABLE && !e->rank))) + { + int parm_rank; + tmp = build_fold_indirect_ref (parmse.expr); + parm_rank = e->rank; + switch (parm_kind) + { + case (ELEMENTAL): + case (SCALAR): + parm_rank = 0; + break; + + case (SCALAR_POINTER): + tmp = build_fold_indirect_ref (tmp); + break; + case (ARRAY): + tmp = parmse.expr; + break; + } + + tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) + tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym), + tmp, build_empty_stmt ()); + + if (e->expr_type != EXPR_VARIABLE) + /* Don't deallocate non-variables until they have been used. */ + gfc_add_expr_to_block (&se->post, tmp); + else + { + gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); + gfc_add_expr_to_block (&se->pre, tmp); + } + } + /* Character strings are passed as two parameters, a length and a pointer. */ if (parmse.string_length != NULL_TREE) *************** gfc_trans_subarray_assign (tree dest, gf *** 2625,2631 **** gfc_conv_expr (&rse, expr); ! tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); --- 2674,2680 ---- gfc_conv_expr (&rse, expr); ! tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); *************** gfc_trans_subarray_assign (tree dest, gf *** 2646,2662 **** --- 2695,2716 ---- return gfc_finish_block (&block); } + /* Assign a single component of a derived type constructor. */ static tree gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_se se; + gfc_se lse; gfc_ss *rss; stmtblock_t block; tree tmp; + tree offset; + int n; gfc_start_block (&block); + if (cm->pointer) { gfc_init_se (&se, NULL); *************** gfc_trans_subcomponent_assign (tree dest *** 2689,2696 **** } else if (cm->dimension) { ! tmp = gfc_trans_subarray_assign (dest, cm, expr); ! gfc_add_expr_to_block (&block, tmp); } else if (expr->ts.type == BT_DERIVED) { --- 2743,2810 ---- } else if (cm->dimension) { ! if (cm->allocatable && expr->expr_type == EXPR_NULL) ! gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); ! else if (cm->allocatable) ! { ! tree tmp2; ! ! gfc_init_se (&se, NULL); ! ! rss = gfc_walk_expr (expr); ! se.want_pointer = 0; ! gfc_conv_expr_descriptor (&se, expr, rss); ! gfc_add_block_to_block (&block, &se.pre); ! ! tmp = fold_convert (TREE_TYPE (dest), se.expr); ! gfc_add_modify_expr (&block, dest, tmp); ! ! if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) ! tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, ! cm->as->rank); ! else ! tmp = gfc_duplicate_allocatable (dest, se.expr, ! TREE_TYPE(cm->backend_decl), ! cm->as->rank); ! ! gfc_add_expr_to_block (&block, tmp); ! ! gfc_add_block_to_block (&block, &se.post); ! gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); ! ! /* Shift the lbound and ubound of temporaries to being unity, rather ! than zero, based. Calculate the offset for all cases. */ ! offset = gfc_conv_descriptor_offset (dest); ! gfc_add_modify_expr (&block, offset, gfc_index_zero_node); ! tmp2 =gfc_create_var (gfc_array_index_type, NULL); ! for (n = 0; n < expr->rank; n++) ! { ! if (expr->expr_type != EXPR_VARIABLE ! && expr->expr_type != EXPR_CONSTANT) ! { ! tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); ! gfc_add_modify_expr (&block, tmp, ! fold_build2 (PLUS_EXPR, ! gfc_array_index_type, ! tmp, gfc_index_one_node)); ! tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); ! gfc_add_modify_expr (&block, tmp, gfc_index_one_node); ! } ! tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, ! gfc_conv_descriptor_lbound (dest, ! gfc_rank_cst[n]), ! gfc_conv_descriptor_stride (dest, ! gfc_rank_cst[n])); ! gfc_add_modify_expr (&block, tmp2, tmp); ! tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); ! gfc_add_modify_expr (&block, offset, tmp); ! } ! } ! else ! { ! tmp = gfc_trans_subarray_assign (dest, cm, expr); ! gfc_add_expr_to_block (&block, tmp); ! } } else if (expr->ts.type == BT_DERIVED) { *************** gfc_trans_subcomponent_assign (tree dest *** 2711,2718 **** else { /* Scalar component. */ - gfc_se lse; - gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); --- 2825,2830 ---- *************** gfc_trans_subcomponent_assign (tree dest *** 2720,2726 **** if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.cl->backend_decl; lse.expr = dest; ! tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); --- 2832,2838 ---- if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.cl->backend_decl; lse.expr = dest; ! tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); *************** gfc_conv_structure (gfc_se * se, gfc_exp *** 2780,2789 **** } cm = expr->ts.derived->components; for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { ! /* Skip absent members in default initializers. */ ! if (!c->expr) continue; val = gfc_conv_initializer (c->expr, &cm->ts, --- 2892,2905 ---- } cm = expr->ts.derived->components; + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { ! /* Skip absent members in default initializers and allocatable ! components. Although the latter have a default initializer ! of EXPR_NULL,... by default, the static nullify is not needed ! since this is done every time we come into scope. */ ! if (!c->expr || cm->allocatable) continue; val = gfc_conv_initializer (c->expr, &cm->ts, *************** gfc_conv_string_parameter (gfc_se * se) *** 3078,3093 **** /* Generate code for assignment of scalar variables. Includes character ! strings. */ tree ! gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) { stmtblock_t block; gfc_init_block (&block); ! if (type == BT_CHARACTER) { gcc_assert (lse->string_length != NULL_TREE && rse->string_length != NULL_TREE); --- 3194,3212 ---- /* Generate code for assignment of scalar variables. Includes character ! strings and derived types with allocatable components. */ tree ! gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, ! bool l_is_temp, bool r_is_var) { stmtblock_t block; + tree tmp; + tree cond; gfc_init_block (&block); ! if (ts.type == BT_CHARACTER) { gcc_assert (lse->string_length != NULL_TREE && rse->string_length != NULL_TREE); *************** gfc_trans_scalar_assign (gfc_se * lse, g *** 3101,3106 **** --- 3220,3269 ---- gfc_trans_string_copy (&block, lse->string_length, lse->expr, rse->string_length, rse->expr); } + else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) + { + cond = NULL_TREE; + + /* Are the rhs and the lhs the same? */ + if (r_is_var) + { + cond = fold_build2 (EQ_EXPR, boolean_type_node, + build_fold_addr_expr (lse->expr), + build_fold_addr_expr (rse->expr)); + cond = gfc_evaluate_now (cond, &lse->pre); + } + + /* Deallocate the lhs allocated components as long as it is not + the same as the rhs. */ + if (!l_is_temp) + { + tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0); + if (r_is_var) + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + gfc_add_modify_expr (&block, lse->expr, + fold_convert (TREE_TYPE (lse->expr), rse->expr)); + + /* Do a deep copy if the rhs is a variable, if it is not the + same as the lhs. Otherwise, nullify the data fields so that the + lhs retains the allocated resources. */ + if (r_is_var) + { + tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0); + gfc_add_expr_to_block (&block, tmp); + } + } else { gfc_add_block_to_block (&block, &lse->pre); *************** gfc_trans_assignment (gfc_expr * expr1, *** 3206,3211 **** --- 3369,3375 ---- tree tmp; stmtblock_t block; stmtblock_t body; + bool l_is_temp; /* Special case a single function returning an array. */ if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) *************** gfc_trans_assignment (gfc_expr * expr1, *** 3284,3293 **** else gfc_init_block (&body); /* Translate the expression. */ gfc_conv_expr (&rse, expr2); ! if (lss != gfc_ss_terminator && loop.temp_ss != NULL) { gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); --- 3448,3459 ---- else gfc_init_block (&body); + l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); + /* Translate the expression. */ gfc_conv_expr (&rse, expr2); ! if (l_is_temp) { gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); *************** gfc_trans_assignment (gfc_expr * expr1, *** 3295,3301 **** else gfc_conv_expr (&lse, expr1); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) --- 3461,3468 ---- else gfc_conv_expr (&lse, expr1); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp, ! expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) *************** gfc_trans_assignment (gfc_expr * expr1, *** 3308,3314 **** gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! if (loop.temp_ss != NULL) { gfc_trans_scalarized_loop_boundary (&loop, &body); --- 3475,3481 ---- gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! if (l_is_temp) { gfc_trans_scalarized_loop_boundary (&loop, &body); *************** gfc_trans_assignment (gfc_expr * expr1, *** 3328,3336 **** gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); gfc_add_expr_to_block (&body, tmp); } /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); --- 3495,3504 ---- gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); gfc_add_expr_to_block (&body, tmp); } + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); Index: gcc/fortran/symbol.c =================================================================== *** gcc/fortran/symbol.c (revision 117054) --- gcc/fortran/symbol.c (working copy) *************** gfc_set_component_attr (gfc_component * *** 1523,1528 **** --- 1523,1529 ---- c->dimension = attr->dimension; c->pointer = attr->pointer; + c->allocatable = attr->allocatable; } *************** gfc_get_component_attr (symbol_attribute *** 1536,1541 **** --- 1537,1543 ---- gfc_clear_attr (attr); attr->dimension = c->dimension; attr->pointer = c->pointer; + attr->allocatable = c->allocatable; } Index: gcc/fortran/intrinsic.h =================================================================== *** gcc/fortran/intrinsic.h (revision 117054) --- gcc/fortran/intrinsic.h (working copy) *************** try gfc_check_free (gfc_expr *); *** 153,158 **** --- 153,159 ---- try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_gerror (gfc_expr *); try gfc_check_getlog (gfc_expr *); + try gfc_check_move_alloc (gfc_expr *, gfc_expr *); try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_random_number (gfc_expr *); Index: gcc/fortran/decl.c =================================================================== *** gcc/fortran/decl.c (revision 117054) --- gcc/fortran/decl.c (working copy) *************** build_struct (const char *name, gfc_char *** 962,975 **** /* Check array components. */ if (!c->dimension) ! return SUCCESS; if (c->pointer) { if (c->as->type != AS_DEFERRED) { ! gfc_error ("Pointer array component of structure at %C " ! "must have a deferred shape"); return FAILURE; } } --- 962,992 ---- /* Check array components. */ if (!c->dimension) ! { ! if (c->allocatable) ! { ! gfc_error ("Allocatable component at %C must be an array"); ! return FAILURE; ! } ! else ! return SUCCESS; ! } if (c->pointer) { if (c->as->type != AS_DEFERRED) { ! gfc_error ("Pointer array component of structure at %C must have a " ! "deferred shape"); ! return FAILURE; ! } ! } ! else if (c->allocatable) ! { ! if (c->as->type != AS_DEFERRED) ! { ! gfc_error ("Allocatable component of structure at %C must have a " ! "deferred shape"); return FAILURE; } } *************** variable_decl (int elem) *** 1284,1289 **** --- 1301,1314 ---- } } + if (initializer != NULL && current_attr.allocatable + && gfc_current_state () == COMP_DERIVED) + { + gfc_error ("Initialization of allocatable component at %C is not allowed"); + m = MATCH_ERROR; + goto cleanup; + } + /* Check if we are parsing an enumeration and if the current enumerator variable has an initializer or not. If it does not have an initializer, the initialization value of the previous enumerator *************** variable_decl (int elem) *** 1315,1322 **** t = add_init_expr_to_sym (name, &initializer, &var_locus); else { ! if (current_ts.type == BT_DERIVED && !current_attr.pointer ! && !initializer) initializer = gfc_default_initializer (¤t_ts); t = build_struct (name, cl, &initializer, &as); } --- 1340,1348 ---- t = add_init_expr_to_sym (name, &initializer, &var_locus); else { ! if (current_ts.type == BT_DERIVED ! && !current_attr.pointer ! && !initializer) initializer = gfc_default_initializer (¤t_ts); t = build_struct (name, cl, &initializer, &as); } *************** match_attr_spec (void) *** 2141,2151 **** && d != DECL_DIMENSION && d != DECL_POINTER && d != DECL_COLON && d != DECL_NONE) { ! ! gfc_error ("Attribute at %L is not allowed in a TYPE definition", ! &seen_at[d]); ! m = MATCH_ERROR; ! goto cleanup; } if ((d == DECL_PRIVATE || d == DECL_PUBLIC) --- 2167,2190 ---- && d != DECL_DIMENSION && d != DECL_POINTER && d != DECL_COLON && d != DECL_NONE) { ! if (d == DECL_ALLOCATABLE) ! { ! if (gfc_notify_std (GFC_STD_F2003, ! "In the selected standard, the ALLOCATABLE " ! "attribute at %C is not allowed in a TYPE " ! "definition") == FAILURE) ! { ! m = MATCH_ERROR; ! goto cleanup; ! } ! } ! else ! { ! gfc_error ("Attribute at %L is not allowed in a TYPE definition", ! &seen_at[d]); ! m = MATCH_ERROR; ! goto cleanup; ! } } if ((d == DECL_PRIVATE || d == DECL_PUBLIC) Index: gcc/fortran/trans-array.h =================================================================== *** gcc/fortran/trans-array.h (revision 117054) --- gcc/fortran/trans-array.h (working copy) *************** tree gfc_trans_dummy_array_bias (gfc_sym *** 43,48 **** --- 43,57 ---- tree gfc_trans_g77_array (gfc_symbol *, tree); /* Generate code to deallocate an array, if it is allocated. */ tree gfc_trans_dealloc_allocated (tree); + + tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank); + + tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int); + + tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int); + + tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int); + /* Add initialization for deferred arrays. */ tree gfc_trans_deferred_array (gfc_symbol *, tree); /* Generate an initializer for a static pointer or allocatable array. */ Index: gcc/fortran/gfortran.texi =================================================================== *** gcc/fortran/gfortran.texi (revision 117054) --- gcc/fortran/gfortran.texi (working copy) *************** available. *** 1370,1376 **** @itemize @item Intrinsics @code{command_argument_count}, @code{get_command}, ! @code{get_command_argument}, and @code{get_environment_variable}. @item @cindex Array constructors --- 1370,1377 ---- @itemize @item Intrinsics @code{command_argument_count}, @code{get_command}, ! @code{get_command_argument}, @code{get_environment_variable}, and ! @code{move_alloc}. @item @cindex Array constructors *************** Support for the declaration of enumerati *** 1397,1410 **** @item @cindex TR 15581 ! The following parts of TR 15581: @itemize @item @cindex @code{ALLOCATABLE} dummy arguments ! The @code{ALLOCATABLE} attribute for dummy arguments. @item @cindex @code{ALLOCATABLE} function results @code{ALLOCATABLE} function results @end itemize @item --- 1398,1414 ---- @item @cindex TR 15581 ! TR 15581: @itemize @item @cindex @code{ALLOCATABLE} dummy arguments ! @code{ALLOCATABLE} dummy arguments. @item @cindex @code{ALLOCATABLE} function results @code{ALLOCATABLE} function results + @item + @cindex @code{ALLOCATABLE} components of derived types + @code{ALLOCATABLE} components of derived types @end itemize @item Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 117054) --- gcc/fortran/gfortran.h (working copy) *************** typedef struct *** 532,537 **** --- 532,540 ---- /* Special attributes for Cray pointers, pointees. */ unsigned cray_pointer:1, cray_pointee:1; + /* The symbol is a derived type with allocatable components, possibly nested. + */ + unsigned alloc_comp:1; } symbol_attribute; *************** typedef struct gfc_component *** 649,655 **** const char *name; gfc_typespec ts; ! int pointer, dimension; gfc_array_spec *as; tree backend_decl; --- 652,658 ---- const char *name; gfc_typespec ts; ! int pointer, allocatable, dimension; gfc_array_spec *as; tree backend_decl; *************** void gfc_resolve_omp_do_blocks (gfc_code *** 1969,1974 **** --- 1972,1978 ---- void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); + gfc_expr *gfc_expr_to_initialize (gfc_expr *); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 117054) --- gcc/fortran/trans-stmt.c (working copy) *************** generate_loop_for_temp_to_lhs (gfc_expr *** 1802,1808 **** gfc_conv_expr (&lse, expr); /* Use the scalar assignment. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); /* Form the mask expression according to the mask tree list. */ if (wheremask) --- 1802,1809 ---- gfc_conv_expr (&lse, expr); /* Use the scalar assignment. */ ! rse.string_length = lse.string_length; ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); /* Form the mask expression according to the mask tree list. */ if (wheremask) *************** generate_loop_for_rhs_to_temp (gfc_expr *** 1897,1903 **** } /* Use the scalar assignment. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); /* Form the mask expression according to the mask tree list. */ if (wheremask) --- 1898,1906 ---- } /* Use the scalar assignment. */ ! lse.string_length = rse.string_length; ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true, ! expr2->expr_type == EXPR_VARIABLE); /* Form the mask expression according to the mask tree list. */ if (wheremask) *************** gfc_trans_where_assign (gfc_expr *expr1, *** 2978,2984 **** maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); --- 2981,2988 ---- maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, ! loop.temp_ss != NULL, false); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); *************** gfc_trans_where_assign (gfc_expr *expr1, *** 3031,3037 **** maskexpr); /* Use the scalar assignment as is. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); --- 3035,3041 ---- maskexpr); /* Use the scalar assignment as is. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); *************** gfc_trans_where_3 (gfc_code * cblock, gf *** 3406,3413 **** gfc_conv_expr (&edse, edst); } ! tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type); ! estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type) : build_empty_stmt (); tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); gfc_add_expr_to_block (&body, tmp); --- 3410,3417 ---- gfc_conv_expr (&edse, edst); } ! tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false); ! estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false) : build_empty_stmt (); tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); gfc_add_expr_to_block (&body, tmp); *************** gfc_trans_allocate (gfc_code * code) *** 3591,3596 **** --- 3595,3608 ---- parm, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&se.pre, tmp); } + + if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp) + { + tmp = build_fold_indirect_ref (se.expr); + tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); + } + } tmp = gfc_finish_block (&se.pre); *************** gfc_trans_deallocate (gfc_code * code) *** 3675,3680 **** --- 3687,3712 ---- se.descriptor_only = 1; gfc_conv_expr (&se, expr); + if (expr->ts.type == BT_DERIVED + && expr->ts.derived->attr.alloc_comp) + { + gfc_ref *ref; + gfc_ref *last = NULL; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + /* Do not deallocate the components of a derived type + ultimate pointer component. */ + if (!(last && last->u.c.component->pointer) + && !(!last && expr->symtree->n.sym->attr.pointer)) + { + tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr, + expr->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } + } + if (expr->rank) tmp = gfc_array_deallocate (se.expr, pstat); else Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 117054) --- gcc/fortran/expr.c (working copy) *************** gfc_default_initializer (gfc_typespec *t *** 2406,2412 **** /* See if we have a default initializer. */ for (c = ts->derived->components; c; c = c->next) { ! if (c->initializer && init == NULL) init = gfc_get_expr (); } --- 2406,2412 ---- /* See if we have a default initializer. */ for (c = ts->derived->components; c; c = c->next) { ! if ((c->initializer || c->allocatable) && init == NULL) init = gfc_get_expr (); } *************** gfc_default_initializer (gfc_typespec *t *** 2430,2435 **** --- 2430,2442 ---- if (c->initializer) tail->expr = gfc_copy_expr (c->initializer); + + if (c->allocatable) + { + tail->expr = gfc_get_expr (); + tail->expr->expr_type = EXPR_NULL; + tail->expr->ts = c->ts; + } } return init; } Index: gcc/fortran/module.c =================================================================== *** gcc/fortran/module.c (revision 117054) --- gcc/fortran/module.c (working copy) *************** typedef enum *** 1435,1441 **** AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, ! AB_CRAY_POINTEE, AB_THREADPRIVATE } ab_attribute; --- 1435,1441 ---- AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, ! AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP } ab_attribute; *************** static const mstring attr_bits[] = *** 1465,1470 **** --- 1465,1471 ---- minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), minit ("CRAY_POINTER", AB_CRAY_POINTER), minit ("CRAY_POINTEE", AB_CRAY_POINTEE), + minit ("ALLOC_COMP", AB_ALLOC_COMP), minit (NULL, -1) }; *************** mio_symbol_attribute (symbol_attribute * *** 1556,1561 **** --- 1557,1565 ---- if (attr->cray_pointee) MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits); + if (attr->alloc_comp) + MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits); + mio_rparen (); } *************** mio_symbol_attribute (symbol_attribute * *** 1644,1649 **** --- 1648,1656 ---- case AB_CRAY_POINTEE: attr->cray_pointee = 1; break; + case AB_ALLOC_COMP: + attr->alloc_comp = 1; + break; } } } *************** mio_component (gfc_component * c) *** 1951,1956 **** --- 1958,1964 ---- mio_integer (&c->dimension); mio_integer (&c->pointer); + mio_integer (&c->allocatable); mio_expr (&c->initializer); mio_rparen (); Index: gcc/fortran/trans-types.c =================================================================== *** gcc/fortran/trans-types.c (revision 117054) --- gcc/fortran/trans-types.c (working copy) *************** gfc_get_derived_type (gfc_symbol * deriv *** 1486,1497 **** /* Derived types in an interface body obtain their parent reference through the proc_name symbol. */ ns = derived->ns->parent ? derived->ns->parent ! : derived->ns->proc_name->ns->parent; for (; ns; ns = ns->parent) { for (dt = ns->derived_types; dt; dt = dt->next) { if (dt->derived->backend_decl == NULL && gfc_compare_derived_types (dt->derived, derived)) gfc_get_derived_type (dt->derived); --- 1486,1500 ---- /* Derived types in an interface body obtain their parent reference through the proc_name symbol. */ ns = derived->ns->parent ? derived->ns->parent ! : derived->ns->proc_name->ns; for (; ns; ns = ns->parent) { for (dt = ns->derived_types; dt; dt = dt->next) { + if (dt->derived == derived) + continue; + if (dt->derived->backend_decl == NULL && gfc_compare_derived_types (dt->derived, derived)) gfc_get_derived_type (dt->derived); *************** gfc_get_derived_type (gfc_symbol * deriv *** 1550,1556 **** required. */ if (c->dimension) { ! if (c->pointer) { /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ --- 1553,1559 ---- required. */ if (c->dimension) { ! if (c->pointer || c->allocatable) { /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 117054) --- gcc/fortran/trans.h (working copy) *************** int gfc_conv_function_call (gfc_se *, gf *** 307,313 **** /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ /* Generate code for a scalar assignment. */ ! tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt); /* Translate COMMON blocks. */ void gfc_trans_common (gfc_namespace *); --- 307,313 ---- /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ /* Generate code for a scalar assignment. */ ! tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool); /* Translate COMMON blocks. */ void gfc_trans_common (gfc_namespace *); Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 117054) --- gcc/fortran/resolve.c (working copy) *************** resolve_structure_cons (gfc_expr * expr) *** 596,611 **** for (; comp; comp = comp->next, cons = cons->next) { ! if (! cons->expr) { t = FAILURE; continue; } ! if (gfc_resolve_expr (cons->expr) == FAILURE) ! { t = FAILURE; - continue; } /* If we don't have the right type, try to convert it. */ --- 596,619 ---- for (; comp; comp = comp->next, cons = cons->next) { ! if (!cons->expr) ! continue; ! ! if (gfc_resolve_expr (cons->expr) == FAILURE) { t = FAILURE; continue; } ! if (cons->expr->expr_type != EXPR_NULL ! && comp->as && comp->as->rank != cons->expr->rank ! && (comp->allocatable || cons->expr->rank)) ! { ! gfc_error ("The rank of the element in the derived type " ! "constructor at %L does not match that of the " ! "component (%d/%d)", &cons->expr->where, ! cons->expr->rank, comp->as ? comp->as->rank : 0); t = FAILURE; } /* If we don't have the right type, try to convert it. */ *************** resolve_deallocate_expr (gfc_expr * e) *** 3312,3318 **** /* Given the expression node e for an allocatable/pointer of derived type to be allocated, get the expression node to be initialized afterwards (needed for ! derived types with default initializers). */ static gfc_expr * expr_to_initialize (gfc_expr * e) --- 3320,3327 ---- /* Given the expression node e for an allocatable/pointer of derived type to be allocated, get the expression node to be initialized afterwards (needed for ! derived types with default initializers, and derived types with allocatable ! components that need nullification.) */ static gfc_expr * expr_to_initialize (gfc_expr * e) *************** resolve_allocate_expr (gfc_expr * e, gfc *** 3421,3428 **** init_st->loc = code->loc; init_st->op = EXEC_ASSIGN; init_st->expr = expr_to_initialize (e); ! init_st->expr2 = init_e; ! init_st->next = code->next; code->next = init_st; } --- 3430,3436 ---- init_st->loc = code->loc; init_st->op = EXEC_ASSIGN; init_st->expr = expr_to_initialize (e); ! init_st->expr2 = init_e; init_st->next = code->next; code->next = init_st; } *************** resolve_transfer (gfc_code * code) *** 4031,4036 **** --- 4039,4051 ---- return; } + if (ts->derived->attr.alloc_comp) + { + gfc_error ("Data transfer element at %L cannot have " + "ALLOCATABLE components", &code->loc); + return; + } + if (derived_inaccessible (ts->derived)) { gfc_error ("Data transfer element at %L cannot have " *************** resolve_fl_derived (gfc_symbol *sym) *** 5412,5418 **** } } ! if (c->pointer || c->as == NULL) continue; for (i = 0; i < c->as->rank; i++) --- 5427,5433 ---- } } ! if (c->pointer || c->allocatable || c->as == NULL) continue; for (i = 0; i < c->as->rank; i++) Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 117054) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 957,962 **** --- 957,965 ---- GFC_DECL_PACKED_ARRAY (decl) = 1; } + if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp) + gfc_defer_symbol_init (sym); + gfc_finish_var_decl (decl, sym); if (sym->ts.type == BT_CHARACTER) *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 2559,2564 **** --- 2562,2569 ---- for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { + bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) + && sym->ts.derived->attr.alloc_comp; if (sym->attr.dimension) { switch (sym->as->type) *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 2601,2613 **** break; case AS_DEFERRED: ! fnbody = gfc_trans_deferred_array (sym, fnbody); break; default: gcc_unreachable (); } } else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); --- 2606,2623 ---- break; case AS_DEFERRED: ! if (!sym_has_alloc_comp) ! fnbody = gfc_trans_deferred_array (sym, fnbody); break; default: gcc_unreachable (); } + if (sym_has_alloc_comp) + fnbody = gfc_trans_deferred_array (sym, fnbody); } + else if (sym_has_alloc_comp) + fnbody = gfc_trans_deferred_array (sym, fnbody); else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); *************** gfc_generate_function_code (gfc_namespac *** 2959,2968 **** --- 2969,2980 ---- tree old_context; tree decl; tree tmp; + tree tmp2; stmtblock_t block; stmtblock_t body; tree result; gfc_symbol *sym; + int rank; sym = ns->proc_name; *************** gfc_generate_function_code (gfc_namespac *** 3122,3128 **** tmp = gfc_finish_block (&body); /* Add code to create and cleanup arrays. */ tmp = gfc_trans_deferred_vars (sym, tmp); - gfc_add_expr_to_block (&block, tmp); if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) { --- 3134,3139 ---- *************** gfc_generate_function_code (gfc_namespac *** 3137,3143 **** else result = sym->result->backend_decl; ! if (result == NULL_TREE) warning (0, "Function return value not set"); else { --- 3148,3165 ---- else result = sym->result->backend_decl; ! if (result != NULL_TREE && sym->attr.function ! && sym->ts.type == BT_DERIVED ! && sym->ts.derived->attr.alloc_comp) ! { ! rank = sym->as ? sym->as->rank : 0; ! tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank); ! gfc_add_expr_to_block (&block, tmp2); ! } ! ! gfc_add_expr_to_block (&block, tmp); ! ! if (result == NULL_TREE) warning (0, "Function return value not set"); else { *************** gfc_generate_function_code (gfc_namespac *** 3148,3153 **** --- 3170,3178 ---- gfc_add_expr_to_block (&block, tmp); } } + else + gfc_add_expr_to_block (&block, tmp); + /* Add all the decls we created during processing. */ decl = saved_function_decls; Index: gcc/fortran/parse.c =================================================================== *** gcc/fortran/parse.c (revision 117054) --- gcc/fortran/parse.c (working copy) *************** parse_derived (void) *** 1499,1504 **** --- 1499,1506 ---- int compiling_type, seen_private, seen_sequence, seen_component, error_flag; gfc_statement st; gfc_state_data s; + gfc_symbol *sym; + gfc_component *c; error_flag = 0; *************** parse_derived (void) *** 1595,1600 **** --- 1597,1614 ---- } } + /* Look for allocatable components. */ + sym = gfc_current_block (); + for (c = sym->components; c; c = c->next) + { + if (c->allocatable || (c->ts.type == BT_DERIVED + && c->ts.derived->attr.alloc_comp)) + { + sym->attr.alloc_comp = 1; + break; + } + } + pop_state (); } Index: gcc/fortran/check.c =================================================================== *** gcc/fortran/check.c (revision 117054) --- gcc/fortran/check.c (working copy) *************** gfc_check_all_any (gfc_expr * mask, gfc_ *** 477,489 **** try gfc_check_allocated (gfc_expr * array) { if (variable_check (array, 0) == FAILURE) return FAILURE; if (array_check (array, 0) == FAILURE) return FAILURE; ! if (!array->symtree->n.sym->attr.allocatable) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[0], gfc_current_intrinsic, --- 477,492 ---- try gfc_check_allocated (gfc_expr * array) { + symbol_attribute attr; + if (variable_check (array, 0) == FAILURE) return FAILURE; if (array_check (array, 0) == FAILURE) return FAILURE; ! attr = gfc_variable_attr (array, NULL); ! if (!attr.allocatable) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[0], gfc_current_intrinsic, *************** gfc_check_merge (gfc_expr * tsource, gfc *** 1814,1819 **** --- 1817,1880 ---- return SUCCESS; } + try + gfc_check_move_alloc (gfc_expr * from, gfc_expr * to) + { + symbol_attribute attr; + + if (variable_check (from, 0) == FAILURE) + return FAILURE; + + if (array_check (from, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (from, NULL); + if (!attr.allocatable) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + &from->where); + return FAILURE; + } + + if (variable_check (to, 0) == FAILURE) + return FAILURE; + + if (array_check (to, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (to, NULL); + if (!attr.allocatable) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + &to->where); + return FAILURE; + } + + if (same_type_check (from, 0, to, 1) == FAILURE) + return FAILURE; + + if (to->rank != from->rank) + { + gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " + "have the same rank %d/%d", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &to->where, from->rank, to->rank); + return FAILURE; + } + + if (to->ts.kind != from->ts.kind) + { + gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " + "be of the same kind %d/%d", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &to->where, from->ts.kind, to->ts.kind); + return FAILURE; + } + + return SUCCESS; + } try gfc_check_nearest (gfc_expr * x, gfc_expr * s) Index: gcc/fortran/primary.c =================================================================== *** gcc/fortran/primary.c (revision 117054) --- gcc/fortran/primary.c (working copy) *************** check_substring: *** 1711,1717 **** symbol_attribute gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts) { ! int dimension, pointer, target; symbol_attribute attr; gfc_ref *ref; --- 1711,1717 ---- symbol_attribute gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts) { ! int dimension, pointer, allocatable, target; symbol_attribute attr; gfc_ref *ref; *************** gfc_variable_attr (gfc_expr * expr, gfc_ *** 1723,1728 **** --- 1723,1729 ---- dimension = attr.dimension; pointer = attr.pointer; + allocatable = attr.allocatable; target = attr.target; if (pointer) *************** gfc_variable_attr (gfc_expr * expr, gfc_ *** 1743,1754 **** break; case AR_SECTION: ! pointer = 0; dimension = 1; break; case AR_ELEMENT: ! pointer = 0; break; case AR_UNKNOWN: --- 1744,1755 ---- break; case AR_SECTION: ! allocatable = pointer = 0; dimension = 1; break; case AR_ELEMENT: ! allocatable = pointer = 0; break; case AR_UNKNOWN: *************** gfc_variable_attr (gfc_expr * expr, gfc_ *** 1763,1780 **** *ts = ref->u.c.component->ts; pointer = ref->u.c.component->pointer; if (pointer) target = 1; break; case REF_SUBSTRING: ! pointer = 0; break; } attr.dimension = dimension; attr.pointer = pointer; attr.target = target; return attr; --- 1764,1783 ---- *ts = ref->u.c.component->ts; pointer = ref->u.c.component->pointer; + allocatable = ref->u.c.component->allocatable; if (pointer) target = 1; break; case REF_SUBSTRING: ! allocatable = pointer = 0; break; } attr.dimension = dimension; attr.pointer = pointer; + attr.allocatable = allocatable; attr.target = target; return attr; Index: gcc/fortran/intrinsic.texi =================================================================== *** gcc/fortran/intrinsic.texi (revision 117054) --- gcc/fortran/intrinsic.texi (working copy) *************** Some intrinsics have documentation yet t *** 181,186 **** --- 181,187 ---- * @code{MINVAL}: MINVAL, Minimum value of an array * @code{MOD}: MOD, Remainder function * @code{MODULO}: MODULO, Modulo function + * @code{MOVE_ALLOC}: MOVE_ALLOC, Move allocation from one object to another * @code{MVBITS}: MVBITS, Move bits from one integer to another * @code{NEAREST}: NEAREST, Nearest representable number * @code{NINT}: NINT, Nearest whole number *************** Elemental subroutine *** 5833,5838 **** --- 5834,5883 ---- + @node MOVE_ALLOC + @section @code{MOVE_ALLOC} --- Move allocation from one object to another + @findex @code{MOVE_ALLOC} intrinsic + @cindex MOVE_ALLOC + + @table @asis + @item @emph{Description}: + @code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to + @var{DEST}. @var{SRC} will become deallocated in the process. + + @item @emph{Option}: + f2003, gnu + + @item @emph{Class}: + Subroutine + + @item @emph{Syntax}: + @code{CALL MOVE_ALLOC(SRC, DEST)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind. + @item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC} + @end multitable + + @item @emph{Return value}: + None + + @item @emph{Example}: + @smallexample + program test_move_alloc + integer, allocatable :: a(:), b(:) + + allocate(a(3)) + a = [ 1, 2, 3 ] + call move_alloc(a, b) + print *, allocated(a), allocated(b) + print *, b + end program test_move_alloc + @end smallexample + @end table + + + @node NEAREST @section @code{NEAREST} --- Nearest representable number @findex @code{NEAREST} intrinsic Index: libgfortran/Makefile.in =================================================================== *** libgfortran/Makefile.in (revision 117054) --- libgfortran/Makefile.in (working copy) *************** am__objects_30 = associated.lo abort.lo *** 167,178 **** eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \ gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \ kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \ ! pack_generic.lo perror.lo signal.lo size.lo sleep.lo \ ! spread_generic.lo string_intrinsics.lo system.lo rand.lo \ ! random.lo rename.lo reshape_generic.lo reshape_packed.lo \ ! selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ ! system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \ ! unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo am__objects_31 = am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ --- 167,178 ---- eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \ gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \ kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \ ! move_alloc.lo pack_generic.lo perror.lo signal.lo size.lo \ ! sleep.lo spread_generic.lo string_intrinsics.lo system.lo \ ! rand.lo random.lo rename.lo reshape_generic.lo \ ! reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ ! stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \ ! tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo am__objects_31 = am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ *************** AUTOHEADER = @AUTOHEADER@ *** 264,269 **** --- 264,270 ---- AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ + CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ *************** EXEEXT = @EXEEXT@ *** 276,281 **** --- 277,283 ---- FC = @FC@ FCFLAGS = @FCFLAGS@ FPU_HOST_HEADER = @FPU_HOST_HEADER@ + GREP = @GREP@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ *************** SET_MAKE = @SET_MAKE@ *** 303,314 **** SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ - ac_ct_AR = @ac_ct_AR@ - ac_ct_AS = @ac_ct_AS@ ac_ct_CC = @ac_ct_CC@ ac_ct_FC = @ac_ct_FC@ - ac_ct_RANLIB = @ac_ct_RANLIB@ - ac_ct_STRIP = @ac_ct_STRIP@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ --- 305,312 ---- *************** build_os = @build_os@ *** 321,326 **** --- 319,327 ---- build_subdir = @build_subdir@ build_vendor = @build_vendor@ datadir = @datadir@ + datarootdir = @datarootdir@ + docdir = @docdir@ + dvidir = @dvidir@ enable_shared = @enable_shared@ enable_static = @enable_static@ exec_prefix = @exec_prefix@ *************** host_cpu = @host_cpu@ *** 331,348 **** --- 332,353 ---- host_os = @host_os@ host_subdir = @host_subdir@ host_vendor = @host_vendor@ + htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ + localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ multi_basedir = @multi_basedir@ oldincludedir = @oldincludedir@ + pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ + psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ sysconfdir = @sysconfdir@ *************** intrinsics/ishftc.c \ *** 418,423 **** --- 423,429 ---- intrinsics/link.c \ intrinsics/malloc.c \ intrinsics/mvbits.c \ + intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ intrinsics/signal.c \ *************** malloc.lo: intrinsics/malloc.c *** 2304,2309 **** --- 2310,2318 ---- mvbits.lo: intrinsics/mvbits.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c + move_alloc.lo: intrinsics/move_alloc.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o move_alloc.lo `test -f 'intrinsics/move_alloc.c' || echo '$(srcdir)/'`intrinsics/move_alloc.c + pack_generic.lo: intrinsics/pack_generic.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c Index: libgfortran/intrinsics/move_alloc.c =================================================================== *** libgfortran/intrinsics/move_alloc.c (revision 0) --- libgfortran/intrinsics/move_alloc.c (revision 0) *************** *** 0 **** --- 1,67 ---- + /* Generic implementation of the MOVE_ALLOC intrinsic + Copyright (C) 2006 Free Software Foundation, Inc. + Contributed by Paul Thomas + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Ligbfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + + #include "libgfortran.h" + + extern void move_alloc (gfc_array_char *, gfc_array_char *); + export_proto(move_alloc); + + void + move_alloc (gfc_array_char * from, gfc_array_char * to) + { + int i; + + internal_free (to->data); + + for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++) + { + to->dim[i].lbound = from->dim[i].lbound; + to->dim[i].ubound = from->dim[i].ubound; + to->dim[i].stride = from->dim[i].stride; + from->dim[i].stride = 0; + from->dim[i].ubound = from->dim[i].lbound; + } + + to->offset = from->offset; + to->dtype = from->dtype; + to->data = from->data; + from->data = NULL; + } + + extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4, + gfc_array_char *, GFC_INTEGER_4); + export_proto(move_alloc_c); + + void + move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)), + gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused))) + { + move_alloc (from, to); + } Index: libgfortran/Makefile.am =================================================================== *** libgfortran/Makefile.am (revision 117054) --- libgfortran/Makefile.am (working copy) *************** intrinsics/ishftc.c \ *** 74,79 **** --- 74,80 ---- intrinsics/link.c \ intrinsics/malloc.c \ intrinsics/mvbits.c \ + intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ intrinsics/signal.c \ Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0) *************** *** 0 **** --- 1,57 ---- + ! { dg-do run } + ! Test assignments of derived type with allocatable components (PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + type :: ivs + character(1), allocatable :: chars(:) + end type ivs + + type(ivs) :: a, b + type(ivs) :: x(3), y(3) + + allocate(a%chars(5)) + a%chars = (/"h","e","l","l","o"/) + + ! An intrinsic assignment must deallocate the l-value and copy across + ! the array from the r-value. + b = a + if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort () + if (allocated (a%chars) .eqv. .false.) call abort () + + ! Scalar to array needs to copy the derived type, to its ultimate components, + ! to each of the l-value elements. */ + x = b + x(2)%chars = (/"g","'","d","a","y"/) + if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort () + if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (allocated (b%chars) .eqv. .false.) call abort () + deallocate (x(1)%chars, x(2)%chars, x(3)%chars) + + ! Array intrinsic assignments are like their scalar counterpart and + ! must deallocate each element of the l-value and copy across the + ! arrays from the r-value elements. + allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5)) + x(1)%chars = (/"h","e","l","l","o"/) + x(2)%chars = (/"g","'","d","a","y"/) + x(3)%chars = (/"g","o","d","a","g"/) + y(2:1:-1) = x(1:2) + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort () + if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort () + + ! In the case of an assignment where there is a dependency, so that a + ! temporary is necessary, each element must be copied to its + ! destination after it has been deallocated. + y(2:3) = y(1:2) + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort () + + ! An identity assignment must not do any deallocation....! + y = y + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () + if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort () + end Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 (revision 0) *************** *** 0 **** --- 1,15 ---- + type :: a + integer, allocatable :: i(:) + end type a + + + type :: c + integer, allocatable :: i(:) + end type c + + type (c) :: x + + print *, x%i(1) + + end + Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0) *************** *** 0 **** --- 1,57 ---- + ! { dg-do run } + ! Test FORALL and WHERE with derived types with allocatable components (PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + type :: a + integer, allocatable :: i(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + integer i, m(4) + + ! Start with scalar and array element assignments in FORALL. + + x(1) = a ((/1, 2, 3, 4/)) + x(2) = a ((/1, 2, 3, 4/) + 10) + forall (j = 1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10) x(j)%i(i) = j*4-i + if (any ((/((x(i)%i(j), j = 1,4), i = 1,2)/) .ne. & + (/1, 2, 1, 0, 11, 12, 5, 4/))) call abort () + + y(1) = b ((/x(1),x(2)/)) + y(2) = b ((/x(2),x(1)/)) + forall (k = 1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10) + y(k)%at(j)%i(i) = j*4-i+k + end forall + if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & + (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () + + ! Now simple assignments in WHERE. + + where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0 + if (any( (/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & + (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () + + where (y((2))%at(:)%i(2) > 8) + y(2)%at(:)%i(2) = 77 + end where + if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & + (/0,0,2,1,11,12,6,5,11,77,3,2,9,8,7,6/))) call abort () + + ! Check that temporaries and full array alloctable component assignments + ! are correctly handled in FORALL. + + x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/) + forall (i=1:2) y(i) = b ((/x(i)/)) + forall (i=1:2) y(i) = y(3-i) ! This needs a temporary. + forall (i=1:2) z(i) = y(i) + if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. & + (/(/5,6,7,8/),(/1,2,3,4/)/))) call abort () + + end Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0) *************** *** 0 **** --- 1,36 ---- + ! { dg-do run } + ! Test assignments of nested derived types with allocatable components(PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + type :: a + integer, allocatable :: i(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + integer i, m(4) + + x(1) = a((/1,2,3,4/)) + x(2) = a((/1,2,3,4/)+10) + + y(1) = b((/x(1),x(2)/)) + y(2) = b((/x(2),x(1)/)) + + y(2) = y(1) + forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) & + y(1)%at(j)%i(k) = 999 + if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) call abort () + + + z = y + forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) & + z(i)%at(j)%i(k) = 999 + if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) call abort () + + end Index: gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0) *************** *** 0 **** --- 1,71 ---- + ! { dg-do run } + ! This checks the correct functioning of derived types with default initializers + ! and allocatable components. + ! + ! Contributed by Salvatore Filippone + ! + module p_type_mod + + type m_type + integer, allocatable :: p(:) + end type m_type + + type basep_type + type(m_type), allocatable :: av(:) + type(m_type), pointer :: ap => null () + integer :: i = 101 + end type basep_type + + type p_type + type(basep_type), allocatable :: basepv(:) + integer :: p1 , p2 = 1 + end type p_type + end module p_type_mod + + program foo + + use p_type_mod + implicit none + + type(m_type), target :: a + type(p_type) :: pre + type(basep_type) :: wee + + call test_ab8 () + + a = m_type ((/101,102/)) + + call p_bld (a, pre) + + if (associated (wee%ap) .or. wee%i /= 101) call abort () + wee%ap => a + if (.not.associated (wee%ap) .or. allocated (wee%av)) call abort () + wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99) + if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) call abort () + + contains + + ! Check that allocatable components are nullified after allocation. + subroutine test_ab8 () + type(p_type) :: p + integer :: ierr + + if (.not.allocated(p%basepv)) then + allocate(p%basepv(1),stat=ierr) + endif + if (allocated (p%basepv) .neqv. .true.) call abort () + if (allocated (p%basepv(1)%av) .neqv. .false.) call abort + if (p%basepv(1)%i .ne. 101) call abort () + + end subroutine test_ab8 + + subroutine p_bld (a, p) + use p_type_mod + type (m_type) :: a + type(p_type) :: p + if (any (a%p .ne. (/101,102/))) call abort () + if (allocated (p%basepv) .or. (p%p2 .ne. 1)) call abort () + end subroutine p_bld + + end program foo + ! { dg-final { cleanup-modules "p_type_mod" } } Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0) *************** *** 0 **** --- 1,63 ---- + ! { dg-do run } + ! Test assignments of nested derived types with character allocatable + ! components(PR 20541). Subroutine test_ab6 checks out a bug in a test + ! version of gfortran's allocatable arrays. + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + type :: a + character(4), allocatable :: ch(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + + character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/) + character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/) + + x(1) = a(chr1) + + ! Check constructor with character array constructors. + x(2) = a((/"qrst","uvwx","yz12","3456"/)) + + y(1) = b((/x(1),x(2)/)) + y(2) = b((/x(2),x(1)/)) + + y(2) = y(1) + + if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. & + (/chr1, chr2/))) call abort () + + call test_ab6 () + + contains + + subroutine test_ab6 () + ! This subroutine tests the presence of a scalar derived type, intermediate + ! in a chain of derived types with allocatable components. + ! Contributed by Salvatore Filippone + + type b + type(a) :: a + end type b + + type c + type(b), allocatable :: b(:) + end type c + + type(c) :: p + type(b) :: bv + + p = c((/b(a((/"Mary","Lamb"/)))/)) + bv = p%b(1) + + if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) call abort () + + end subroutine test_ab6 + + end Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0) *************** *** 0 **** --- 1,108 ---- + ! { dg-do run } + ! { dg-options "-fdump-tree-original" } + ! Test constructors of derived type with allocatable components (PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + + Program test_constructor + + implicit none + + type :: thytype + integer(4) :: a(2,2) + end type thytype + + type :: mytype + integer(4), allocatable :: a(:, :) + type(thytype), allocatable :: q(:) + end type mytype + + type (mytype) :: x + type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) + integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2]) + integer, allocatable :: yy(:,:) + type (thytype), allocatable :: bar(:) + integer :: i + + ! Check that null() works + x = mytype(null(), null()) + if (allocated(x%a) .or. allocated(x%q)) call abort() + + ! Check that unallocated allocatables work + x = mytype(yy, bar) + if (allocated(x%a) .or. allocated(x%q)) call abort() + + ! Check that non-allocatables work + x = mytype(y, [foo, foo]) + if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() + if (any(lbound(x%a) /= lbound(y))) call abort() + if (any(ubound(x%a) /= ubound(y))) call abort() + if (any(x%a /= y)) call abort() + if (size(x%q) /= 2) call abort() + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) call abort() + end do + + ! Check that allocated allocatables work + allocate(yy(size(y,1), size(y,2))) + yy = y + allocate(bar(2)) + bar = [foo, foo] + x = mytype(yy, bar) + if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() + if (any(x%a /= y)) call abort() + if (size(x%q) /= 2) call abort() + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) call abort() + end do + + ! Functions returning arrays + x = mytype(bluhu(), null()) + if (.not.allocated(x%a) .or. allocated(x%q)) call abort() + if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort() + + ! Functions returning allocatable arrays + x = mytype(blaha(), null()) + if (.not.allocated(x%a) .or. allocated(x%q)) call abort() + if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort() + + ! Check that passing the constructor to a procedure works + call check_mytype (mytype(y, [foo, foo])) + + contains + + subroutine check_mytype(x) + type(mytype), intent(in) :: x + integer :: i + + if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() + if (any(lbound(x%a) /= lbound(y))) call abort() + if (any(ubound(x%a) /= ubound(y))) call abort() + if (any(x%a /= y)) call abort() + if (size(x%q) /= 2) call abort() + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) call abort() + end do + + end subroutine check_mytype + + + function bluhu() + integer :: bluhu(2,2) + + bluhu = reshape ([41, 98, 54, 76], [2,2]) + end function bluhu + + + function blaha() + integer, allocatable :: blaha(:,:) + + allocate(blaha(2,2)) + blaha = reshape ([40, 97, 53, 75], [2,2]) + end function blaha + + end program test_constructor + ! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } } + ! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0) *************** *** 0 **** --- 1,26 ---- + ! { dg-do run } + ! Test constructors of nested derived types with allocatable components(PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + type :: thytype + integer(4), allocatable :: h(:) + end type thytype + + type :: mytype + type(thytype), allocatable :: q(:) + end type mytype + + type (mytype) :: x + type (thytype) :: w(2) + integer :: y(2) =(/1,2/) + + w = (/thytype(y), thytype (2*y)/) + x = mytype (w) + if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort () + + x = mytype ((/thytype(3*y), thytype (4*y)/)) + if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort () + + end Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0) *************** *** 0 **** --- 1,143 ---- + ! { dg-do run} + ! { dg-options "-O2 -fdump-tree-original" } + ! + ! Check some basic functionality of allocatable components, including that they + ! are nullified when created and automatically deallocated when + ! 1. A variable goes out of scope + ! 2. INTENT(OUT) dummies + ! 3. Function results + ! + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + module alloc_m + + implicit none + + type :: alloc1 + real, allocatable :: x(:) + end type alloc1 + + end module alloc_m + + + program alloc + + use alloc_m + + implicit none + + type :: alloc2 + type(alloc1), allocatable :: a1(:) + integer, allocatable :: a2(:) + end type alloc2 + + type(alloc2) :: b + integer :: i + type(alloc2), allocatable :: c(:) + + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'main - 1' + call abort() + end if + + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(b) + call check_alloc2(b) + + do i = 1, size(b%a1) + ! 1 call to _gfortran_deallocate + deallocate(b%a1(i)%x) + end do + + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(b) + + call check_alloc2(return_alloc2()) + ! 3 calls to _gfortran_deallocate (function result) + + allocate(c(1)) + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(c(1)) + ! 4 calls to _gfortran_deallocate + deallocate(c) + + ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope) + + contains + + subroutine allocate_alloc2(b) + type(alloc2), intent(out) :: b + integer :: i + + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'allocate_alloc2 - 1' + call abort() + end if + + allocate (b%a2(3)) + b%a2 = [ 1, 2, 3 ] + + allocate (b%a1(3)) + + do i = 1, 3 + if (allocated(b%a1(i)%x)) then + write (0, *) 'allocate_alloc2 - 2', i + call abort() + end if + allocate (b%a1(i)%x(3)) + b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] + end do + + end subroutine allocate_alloc2 + + + type(alloc2) function return_alloc2() result(b) + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'return_alloc2 - 1' + call abort() + end if + + allocate (b%a2(3)) + b%a2 = [ 1, 2, 3 ] + + allocate (b%a1(3)) + + do i = 1, 3 + if (allocated(b%a1(i)%x)) then + write (0, *) 'return_alloc2 - 2', i + call abort() + end if + allocate (b%a1(i)%x(3)) + b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] + end do + end function return_alloc2 + + + subroutine check_alloc2(b) + type(alloc2), intent(in) :: b + + if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then + write (0, *) 'check_alloc2 - 1' + call abort() + end if + if (any(b%a2 /= [ 1, 2, 3 ])) then + write (0, *) 'check_alloc2 - 2' + call abort() + end if + do i = 1, 3 + if (.NOT.allocated(b%a1(i)%x)) then + write (0, *) 'check_alloc2 - 3', i + call abort() + end if + if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then + write (0, *) 'check_alloc2 - 4', i + call abort() + end if + end do + end subroutine check_alloc2 + + end program alloc + ! { dg-final { scan-tree-dump-times "deallocate" 38 "original" } } + ! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0) *************** *** 0 **** --- 1,39 ---- + ! { dg-do run } + ! Check "double" allocations of allocatable components (PR 20541). + ! + ! Contributed by Erik Edelmann + ! and Paul Thomas + ! + program main + + implicit none + + type foo + integer, dimension(:), allocatable :: array + end type foo + + type(foo),allocatable,dimension(:) :: mol + type(foo),pointer,dimension(:) :: molp + integer :: i + + allocate (mol(1)) + allocate (mol(1), stat=i) + !print *, i ! /= 0 + if (i == 0) call abort() + + allocate (mol(1)%array(5)) + allocate (mol(1)%array(5),stat=i) + !print *, i ! /= 0 + if (i == 0) call abort() + + allocate (molp(1)) + allocate (molp(1), stat=i) + !print *, i ! == 0 + if (i /= 0) call abort() + + allocate (molp(1)%array(5)) + allocate (molp(1)%array(5),stat=i) + !print *, i ! /= 0 + if (i == 0) call abort() + + end program main