Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 116273) +++ gcc/fortran/interface.c (working copy) @@ -374,6 +374,9 @@ gfc_compare_derived_types (gfc_symbol * 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 116273) +++ gcc/fortran/intrinsic.c (working copy) @@ -2391,6 +2391,11 @@ add_subroutines (void) 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 116273) +++ gcc/fortran/trans-array.c (working copy) @@ -3227,9 +3227,8 @@ gfc_array_allocate (gfc_se * se, gfc_exp tree size; gfc_expr **lower; gfc_expr **upper; - gfc_ref *ref; - int allocatable_array; - int must_be_pointer; + gfc_ref *ref, *prev_ref = NULL; + bool allocatable_array; ref = expr->ref; @@ -3238,21 +3237,34 @@ gfc_array_allocate (gfc_se * se, gfc_exp We test this by checking for ref->next. An implementation of TR 15581 would need to change this. */ + #if 0 if (ref) must_be_pointer = ref->next != NULL; else must_be_pointer = 0; + + if (must_be_pointer) + allocatable_array = 0; + else + allocatable_array = expr->symtree->n.sym->attr.allocatable; + #endif /* 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) { @@ -3285,11 +3297,6 @@ gfc_array_allocate (gfc_se * se, gfc_exp 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) @@ -3316,6 +3323,13 @@ gfc_array_allocate (gfc_se * se, gfc_exp 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; } @@ -3456,6 +3470,9 @@ gfc_conv_array_initializer (tree type, g } break; + case EXPR_NULL: + return gfc_build_null_descriptor (type); + default: gcc_unreachable (); } @@ -4538,6 +4555,17 @@ gfc_conv_array_parameter (gfc_se * se, g 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; @@ -4586,21 +4614,296 @@ tree gfc_trans_dealloc_allocated (tree descriptor) { tree tmp; - tree deallocate; + tree ptr; + tree var; 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 ()); + 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); +} - tmp = gfc_finish_block (&block); - return tmp; +/* 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); +} + + +/* 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, dvar; + tree cdecl; + tree ctype; + tree vref, dref; + + 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. */ + nelems = get_full_array_size (&fnblock, decl, rank); + + /* Set the result to -1 if already deallocated, so that the + loop does not run. */ + tmp = gfc_conv_descriptor_data_get (decl); + tmp = build2 (NE_EXPR, boolean_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = build3 (COND_EXPR, gfc_array_index_type, tmp, + nelems, gfc_index_zero_node); + tmp = gfc_evaluate_now (tmp, &fnblock); + tmp = build2 (MINUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + } + else + { + /* Otherwise use the TYPE_DOMAIN information. */ + tmp = array_type_nelts (TREE_TYPE (decl)); + tmp = fold_convert (gfc_array_index_type, tmp); + } + + 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) + { + dvar = build_fold_indirect_ref (gfc_conv_array_data (dest)); + dref = gfc_build_array_ref (dvar, index); + tmp = structure_alloc_comps (der_type, vref, dref, 0, purpose); + } + else + tmp = structure_alloc_comps (der_type, vref, NULL_TREE, 0, 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); + return gfc_finish_block (&fnblock); + } + + /* Otherwise, deallocate the components or recursively call self to + deallocate the components of components. */ + for (c = der_type->components; c; c = c->next) + { + cdecl = c->backend_decl; + ctype = TREE_TYPE (cdecl); + + switch (purpose) + { + case DEALLOCATE_ALLOC_COMP: + /* Do not deallocate the components of ultimate pointer + components. */ + if (c->ts.type == BT_DERIVED + && c->ts.derived->attr.alloc_comp + && !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 (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp) + { + 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; + + 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) + { + tree size; + 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, dcmp, + null_pointer_node); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + nelems = get_full_array_size (&block, comp, c->as->rank); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, + TYPE_SIZE_UNIT (gfc_get_element_type (ctype))); + + /* 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 (comp)), + tmp)); + gfc_conv_descriptor_data_set (&block, dcmp, tmp); + + /* We know the temporary and the value will be the same length, + so can use memcpy. */ + tmp = gfc_conv_descriptor_data_get (dcmp); + args = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_conv_descriptor_data_get (comp); + 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 (comp); + null_cond = convert (pvoid_type_node, null_cond); + null_cond = build2 (NE_EXPR, boolean_type_node, null_cond, + null_pointer_node); + tmp = build3_v (COND_EXPR, null_cond, tmp, null_data); + gfc_add_expr_to_block (&fnblock, tmp); + } + + if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp) + { + rank = c->as ? c->as->rank : 0; + 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); } @@ -4614,16 +4917,18 @@ gfc_trans_deferred_array (gfc_symbol * s tree descriptor; stmtblock_t fnblock; locus loc; + int rank; /* 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."); + if (!(sym->attr.pointer || sym->attr.allocatable + || (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp))) + fatal_error ("Possible frontend bug: Deferred array size without pointer" + "allocatable attribute."); gfc_init_block (&fnblock); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL - || TREE_CODE (sym->backend_decl) == PARM_DECL); + || TREE_CODE (sym->backend_decl) == PARM_DECL); if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) @@ -4653,22 +4958,43 @@ gfc_trans_deferred_array (gfc_symbol * s /* Get the descriptor type. */ type = TREE_TYPE (sym->backend_decl); - if (!GFC_DESCRIPTOR_TYPE_P (type)) + + if (sym->ts.type == BT_DERIVED + && sym->ts.derived->attr.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); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); } - + /* NULLIFY the data pointer. */ - gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); + 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. */ + + /* Allocatable arrays need to be freed when they go out of scope. + The allocatable components of pointers must not be touched. */ + if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.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 116273) +++ gcc/fortran/trans-expr.c (working copy) @@ -42,7 +42,7 @@ Software Foundation, 51 Franklin Street, #include "trans-stmt.h" #include "dependency.h" -static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); +static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); @@ -1702,7 +1702,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, g if (intent != INTENT_OUT) { - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + 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); @@ -1787,7 +1787,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, g gcc_assert (lse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ @@ -1859,6 +1859,7 @@ gfc_conv_function_call (gfc_se * se, gfc gfc_ss *argss; gfc_ss_info *info; int byref; + int parm_kind; tree type; tree var; tree len; @@ -1872,6 +1873,7 @@ gfc_conv_function_call (gfc_se * se, gfc gfc_expr *e; gfc_symbol *fsym; stmtblock_t post; + enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; arglist = NULL_TREE; retargs = NULL_TREE; @@ -1914,6 +1916,7 @@ gfc_conv_function_call (gfc_se * se, gfc { e = arg->expr; fsym = formal ? formal->sym : NULL; + parm_kind = MISSING; if (e == NULL) { @@ -1942,6 +1945,7 @@ gfc_conv_function_call (gfc_se * se, gfc /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); gfc_conv_expr_reference (&parmse, e); + parm_kind = ELEMENTAL; } else { @@ -1952,12 +1956,14 @@ gfc_conv_function_call (gfc_se * se, gfc 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); } } @@ -2024,6 +2030,49 @@ gfc_conv_function_call (gfc_se * se, gfc gfc_add_expr_to_block (&se->pre, tmp); } + /* 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) @@ -2600,7 +2649,7 @@ gfc_trans_subarray_assign (tree dest, gf gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type); + 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); @@ -2624,14 +2673,24 @@ gfc_trans_subarray_assign (tree dest, gf /* Assign a single component of a derived type constructor. */ static tree -gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) +gfc_trans_subcomponent_assign (gfc_se * outer_se, 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 0 + if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) + gfc_todo_error ("derived types with allocatable components as " + "arguments of derived type constructors"); +#endif if (cm->pointer) { gfc_init_se (&se, NULL); @@ -2664,8 +2723,75 @@ gfc_trans_subcomponent_assign (tree dest } else if (cm->dimension) { - tmp = gfc_trans_subarray_assign (dest, cm, expr); - gfc_add_expr_to_block (&block, tmp); + 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); + gfc_init_se (&lse, NULL); + + se.want_pointer = 0; + gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr)); + if (cm->ts.type == BT_CHARACTER) + lse.string_length = cm->ts.cl->backend_decl; + + lse.expr = dest; + + /* Clean up temporaries at the right time. */ + if (expr->expr_type == EXPR_FUNCTION) + { + stmtblock_t tmp_block; + + /* Prevent the freeing of the memory after the array assignment to + the derived type component.... */ + gfc_init_block (&tmp_block); + gfc_add_block_to_block (&tmp_block, &se.post); + gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node); + gfc_add_block_to_block (&se.post, &tmp_block); + + /* ...and do it when the derived type is completed. */ + tmp = gfc_conv_descriptor_data_get (lse.expr); + tmp = convert (pvoid_type_node, tmp); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&outer_se->post, tmp); + } + + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); + gfc_add_expr_to_block (&block, tmp); + + /* 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) { @@ -2679,15 +2805,13 @@ gfc_trans_subcomponent_assign (tree dest else { /* Nested constructors. */ - tmp = gfc_trans_structure_assign (dest, expr); + tmp = gfc_trans_structure_assign (outer_se, dest, expr); gfc_add_expr_to_block (&block, tmp); } } else { /* Scalar component. */ - gfc_se lse; - gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -2695,7 +2819,7 @@ gfc_trans_subcomponent_assign (tree dest 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); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -2704,7 +2828,7 @@ gfc_trans_subcomponent_assign (tree dest /* Assign a derived type constructor to a variable. */ static tree -gfc_trans_structure_assign (tree dest, gfc_expr * expr) +gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr) { gfc_constructor *c; gfc_component *cm; @@ -2722,7 +2846,7 @@ gfc_trans_structure_assign (tree dest, g field = cm->backend_decl; tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE); - tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr); + tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -2749,7 +2873,7 @@ gfc_conv_structure (gfc_se * se, gfc_exp { /* Create a temporary variable and fill it in. */ se->expr = gfc_create_var (type, expr->ts.derived->name); - tmp = gfc_trans_structure_assign (se->expr, expr); + tmp = gfc_trans_structure_assign (se, se->expr, expr); gfc_add_expr_to_block (&se->pre, tmp); return; } @@ -3056,13 +3180,16 @@ gfc_conv_string_parameter (gfc_se * se) strings. */ tree -gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) +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 (type == BT_CHARACTER) + if (ts.type == BT_CHARACTER) { gcc_assert (lse->string_length != NULL_TREE && rse->string_length != NULL_TREE); @@ -3076,6 +3203,50 @@ gfc_trans_scalar_assign (gfc_se * lse, g 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, as long as 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); @@ -3270,7 +3441,9 @@ gfc_trans_assignment (gfc_expr * expr1, else gfc_conv_expr (&lse, expr1); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + loop.temp_ss != NULL, + expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -3303,9 +3476,10 @@ gfc_trans_assignment (gfc_expr * expr1, gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + 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 116273) +++ gcc/fortran/symbol.c (working copy) @@ -1598,6 +1598,7 @@ gfc_set_component_attr (gfc_component * c->dimension = attr->dimension; c->pointer = attr->pointer; + c->allocatable = attr->allocatable; } @@ -1611,6 +1612,7 @@ gfc_get_component_attr (symbol_attribute 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 116273) +++ gcc/fortran/intrinsic.h (working copy) @@ -153,6 +153,7 @@ try gfc_check_free (gfc_expr *); 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 116273) +++ gcc/fortran/decl.c (working copy) @@ -957,14 +957,31 @@ build_struct (const char *name, gfc_char /* Check array components. */ if (!c->dimension) - return SUCCESS; + { + 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"); + 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; } } @@ -2136,11 +2153,24 @@ match_attr_spec (void) && 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_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 116273) +++ gcc/fortran/trans-array.h (working copy) @@ -43,6 +43,13 @@ tree gfc_trans_dummy_array_bias (gfc_sym 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_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 116273) +++ gcc/fortran/gfortran.texi (working copy) @@ -1346,7 +1346,8 @@ available. @itemize @item Intrinsics @code{command_argument_count}, @code{get_command}, -@code{get_command_argument}, and @code{get_environment_variable}. +@code{get_command_argument}, @code{get_environment_variable}, and +@code{move_alloc}. @item @cindex Array constructors @@ -1373,14 +1374,17 @@ Support for the declaration of enumerati @item @cindex TR 15581 -The following parts of TR 15581: +TR 15581: @itemize @item @cindex @code{ALLOCATABLE} dummy arguments -The @code{ALLOCATABLE} attribute for 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 116273) +++ gcc/fortran/gfortran.h (working copy) @@ -532,6 +532,9 @@ typedef struct /* 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; @@ -649,7 +652,7 @@ typedef struct gfc_component const char *name; gfc_typespec ts; - int pointer, dimension; + int pointer, allocatable, dimension; gfc_array_spec *as; tree backend_decl; @@ -1955,6 +1958,7 @@ void gfc_resolve_omp_do_blocks (gfc_code 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 116273) +++ gcc/fortran/trans-stmt.c (working copy) @@ -1796,7 +1796,7 @@ generate_loop_for_temp_to_lhs (gfc_expr gfc_conv_expr (&lse, expr); /* Use the scalar assignment. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); /* Form the mask expression according to the mask tree list. */ if (wheremask) @@ -1891,7 +1891,7 @@ generate_loop_for_rhs_to_temp (gfc_expr } /* Use the scalar assignment. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false); /* Form the mask expression according to the mask tree list. */ if (wheremask) @@ -2972,7 +2972,8 @@ gfc_trans_where_assign (gfc_expr *expr1, 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 = 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); @@ -3025,7 +3026,7 @@ gfc_trans_where_assign (gfc_expr *expr1, maskexpr); /* Use the scalar assignment as is. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + 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); @@ -3400,8 +3401,8 @@ gfc_trans_where_3 (gfc_code * cblock, gf 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) + 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); @@ -3585,6 +3586,14 @@ gfc_trans_allocate (gfc_code * code) 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); @@ -3669,6 +3678,26 @@ gfc_trans_deallocate (gfc_code * code) 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/module.c =================================================================== --- gcc/fortran/module.c (revision 116273) +++ gcc/fortran/module.c (working copy) @@ -1435,7 +1435,7 @@ typedef enum 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_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP } ab_attribute; @@ -1465,6 +1465,8 @@ static const mstring attr_bits[] = minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), minit ("CRAY_POINTER", AB_CRAY_POINTER), minit ("CRAY_POINTEE", AB_CRAY_POINTEE), + minit ("CRAY_POINTEE", AB_CRAY_POINTEE), + minit ("ALLOC_COMP", AB_ALLOC_COMP), minit (NULL, -1) }; @@ -1556,6 +1558,9 @@ mio_symbol_attribute (symbol_attribute * 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 (); } @@ -1644,6 +1649,9 @@ mio_symbol_attribute (symbol_attribute * case AB_CRAY_POINTEE: attr->cray_pointee = 1; break; + case AB_ALLOC_COMP: + attr->alloc_comp = 1; + break; } } } @@ -1951,6 +1959,7 @@ mio_component (gfc_component * c) 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 116273) +++ gcc/fortran/trans-types.c (working copy) @@ -1480,7 +1480,7 @@ gfc_get_derived_type (gfc_symbol * deriv required. */ if (c->dimension) { - if (c->pointer) + 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 116273) +++ gcc/fortran/trans.h (working copy) @@ -307,7 +307,7 @@ int gfc_conv_function_call (gfc_se *, gf /* 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); +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 116273) +++ gcc/fortran/resolve.c (working copy) @@ -919,13 +919,12 @@ resolve_actual_arglist (gfc_actual_argli /* Do the checks of the actual argument list that are specific to elemental - procedures. If called with c == NULL, we have a function, otherwise if - expr == NULL, we have a subroutine. */ + procedures. */ static try resolve_elemental_actual (gfc_expr *expr, gfc_code *c) { - gfc_actual_arglist *arg0; - gfc_actual_arglist *arg; + gfc_actual_arglist * arg0; + gfc_actual_arglist * arg; gfc_symbol *esym = NULL; gfc_intrinsic_sym *isym = NULL; gfc_expr *e = NULL; @@ -936,7 +935,6 @@ resolve_elemental_actual (gfc_expr *expr int i; int rank = 0; - /* Is this an elemental procedure? */ if (expr && expr->value.function.actual != NULL) { if (expr->value.function.esym != NULL @@ -973,7 +971,7 @@ resolve_elemental_actual (gfc_expr *expr && arg->expr->symtree->n.sym->attr.optional) set_by_optional = true; - /* Function specific; set the result rank and shape. */ + /* Function specific. */ if (expr) { expr->rank = rank; @@ -3310,7 +3308,8 @@ resolve_deallocate_expr (gfc_expr * e) /* 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). */ + derived types with default initializers, and derived types with allocatable + components that need nullification.) */ static gfc_expr * expr_to_initialize (gfc_expr * e) @@ -3419,8 +3418,7 @@ resolve_allocate_expr (gfc_expr * e, gfc init_st->loc = code->loc; init_st->op = EXEC_ASSIGN; init_st->expr = expr_to_initialize (e); - init_st->expr2 = init_e; - + init_st->expr2 = init_e; init_st->next = code->next; code->next = init_st; } @@ -4029,6 +4027,13 @@ resolve_transfer (gfc_code * code) 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 " @@ -5409,7 +5414,7 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (c->pointer || c->as == NULL) + 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 116273) +++ gcc/fortran/trans-decl.c (working copy) @@ -957,6 +957,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) 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) @@ -2601,13 +2604,19 @@ gfc_trans_deferred_vars (gfc_symbol * pr break; case AS_DEFERRED: - fnbody = gfc_trans_deferred_array (sym, fnbody); + if (!(sym->ts.type == BT_DERIVED + && sym->ts.derived->attr.alloc_comp)) + fnbody = gfc_trans_deferred_array (sym, fnbody); break; default: gcc_unreachable (); } + if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp) + fnbody = gfc_trans_deferred_array (sym, fnbody); } + else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp) + fnbody = gfc_trans_deferred_array (sym, fnbody); else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); @@ -2957,10 +2966,12 @@ gfc_generate_function_code (gfc_namespac 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; @@ -3120,7 +3131,6 @@ gfc_generate_function_code (gfc_namespac 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) { @@ -3135,7 +3145,18 @@ gfc_generate_function_code (gfc_namespac else result = sym->result->backend_decl; - if (result == NULL_TREE) + 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 { @@ -3146,6 +3167,9 @@ gfc_generate_function_code (gfc_namespac 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 116273) +++ gcc/fortran/parse.c (working copy) @@ -1499,6 +1499,8 @@ parse_derived (void) 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; @@ -1595,6 +1597,18 @@ parse_derived (void) } } + /* 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 116273) +++ gcc/fortran/check.c (working copy) @@ -477,13 +477,16 @@ gfc_check_all_any (gfc_expr * mask, gfc_ 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; - if (!array->symtree->n.sym->attr.allocatable) + 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, @@ -1814,6 +1817,64 @@ gfc_check_merge (gfc_expr * tsource, gfc 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 116273) +++ gcc/fortran/primary.c (working copy) @@ -1711,7 +1711,7 @@ check_substring: symbol_attribute gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts) { - int dimension, pointer, target; + int dimension, pointer, allocatable, target; symbol_attribute attr; gfc_ref *ref; @@ -1723,6 +1723,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_ dimension = attr.dimension; pointer = attr.pointer; + allocatable = attr.allocatable; target = attr.target; if (pointer) @@ -1743,12 +1744,12 @@ gfc_variable_attr (gfc_expr * expr, gfc_ break; case AR_SECTION: - pointer = 0; + allocatable = pointer = 0; dimension = 1; break; case AR_ELEMENT: - pointer = 0; + allocatable = pointer = 0; break; case AR_UNKNOWN: @@ -1763,18 +1764,20 @@ gfc_variable_attr (gfc_expr * expr, gfc_ *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: - pointer = 0; + 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 116273) +++ gcc/fortran/intrinsic.texi (working copy) @@ -112,6 +112,7 @@ and editing. All contributions and corr * @code{MINEXPONENT}: MINEXPONENT, Minimum exponent of a real kind * @code{MOD}: MOD, Remainder function * @code{MODULO}: MODULO, Modulo function +* @code{MOVE_ALLOC}: MOVE_ALLOC, Move allocation from one object to another * @code{NEAREST}: NEAREST, Nearest representable number * @code{NINT}: NINT, Nearest whole number * @code{PRECISION}: PRECISION, Decimal precision of a real kind @@ -3869,6 +3870,50 @@ end program test_mod +@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 116273) +++ libgfortran/Makefile.in (working copy) @@ -167,12 +167,12 @@ am__objects_30 = associated.lo abort.lo 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 \ + 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 \ @@ -264,6 +264,7 @@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ +CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ @@ -276,6 +277,7 @@ EXEEXT = @EXEEXT@ FC = @FC@ FCFLAGS = @FCFLAGS@ FPU_HOST_HEADER = @FPU_HOST_HEADER@ +GREP = @GREP@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ @@ -303,12 +305,8 @@ SET_MAKE = @SET_MAKE@ 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@ @@ -321,6 +319,9 @@ build_os = @build_os@ 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@ @@ -331,18 +332,22 @@ host_cpu = @host_cpu@ 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@ @@ -418,6 +423,7 @@ intrinsics/ishftc.c \ intrinsics/link.c \ intrinsics/malloc.c \ intrinsics/mvbits.c \ +intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ intrinsics/signal.c \ @@ -2304,6 +2310,9 @@ malloc.lo: intrinsics/malloc.c 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,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 116273) +++ libgfortran/Makefile.am (working copy) @@ -74,6 +74,7 @@ intrinsics/ishftc.c \ intrinsics/link.c \ intrinsics/malloc.c \ intrinsics/mvbits.c \ +intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ intrinsics/signal.c \