GCC Bugzilla – Attachment 11975 Details for
Bug 20541
TR 15581: ALLOCATABLE components
Home
|
New
|
Browse
|
Search
|
[?]
|
Reports
|
Help
|
New Account
|
Log In
Remember
[x]
|
Forgot Password
Login:
[x]
[patch]
Latest version
tr15581_0731.diff (text/plain), 55.80 KB, created by
eedelman
on 2006-07-30 21:38:46 UTC
(
hide
)
Description:
Latest version
Filename:
MIME Type:
Creator:
eedelman
Created:
2006-07-30 21:38:46 UTC
Size:
55.80 KB
patch
obsolete
>Index: gcc/fortran/interface.c >=================================================================== >--- gcc/fortran/interface.c (revision 115800) >+++ 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 115800) >+++ gcc/fortran/intrinsic.c (working copy) >@@ -2354,6 +2354,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 115800) >+++ gcc/fortran/trans-array.c (working copy) >@@ -3316,6 +3316,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 +3463,9 @@ gfc_conv_array_initializer (tree type, g > } > break; > >+ case EXPR_NULL: >+ return gfc_build_null_descriptor (type); >+ > default: > gcc_unreachable (); > } >@@ -4538,6 +4548,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 +4607,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 +4910,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 +4951,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 115800) >+++ 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); > } > } >@@ -2014,6 +2020,49 @@ gfc_conv_function_call (gfc_se * se, gfc > gfc_add_block_to_block (&se->pre, &parmse.pre); > gfc_add_block_to_block (&post, &parmse.post); > >+ /* 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) >@@ -2590,7 +2639,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); >@@ -2614,14 +2663,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); >@@ -2654,20 +2713,85 @@ 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) > { > /* Nested derived type. */ >- 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); > >@@ -2675,7 +2799,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); >@@ -2684,7 +2808,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; >@@ -2702,7 +2826,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); >@@ -2729,7 +2853,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; > } >@@ -3036,13 +3160,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); >@@ -3056,6 +3183,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); >@@ -3250,7 +3421,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) >@@ -3283,9 +3456,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 115800) >+++ gcc/fortran/symbol.c (working copy) >@@ -1523,6 +1523,7 @@ gfc_set_component_attr (gfc_component * > > c->dimension = attr->dimension; > c->pointer = attr->pointer; >+ c->allocatable = attr->allocatable; > } > > >@@ -1536,6 +1537,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 115800) >+++ gcc/fortran/intrinsic.h (working copy) >@@ -150,6 +150,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 115800) >+++ gcc/fortran/decl.c (working copy) >@@ -963,14 +963,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; > } > } >@@ -2142,11 +2159,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 115800) >+++ 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 115800) >+++ 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 > > @end itemize >Index: gcc/fortran/gfortran.h >=================================================================== >--- gcc/fortran/gfortran.h (revision 115800) >+++ gcc/fortran/gfortran.h (working copy) >@@ -528,6 +528,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; > >@@ -645,7 +648,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; >@@ -1965,6 +1968,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 115800) >+++ 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 115800) >+++ 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 115800) >+++ gcc/fortran/trans-types.c (working copy) >@@ -1547,7 +1547,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 115800) >+++ 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 115800) >+++ gcc/fortran/resolve.c (working copy) >@@ -911,13 +911,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; >@@ -928,7 +927,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 >@@ -965,7 +963,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; >@@ -1007,7 +1005,7 @@ resolve_elemental_actual (gfc_expr *expr > else if (isym) > formal_optional = true; > >- if (arg->expr != NULL >+ if (arg->expr !=NULL > && arg->expr->expr_type == EXPR_VARIABLE > && arg->expr->symtree->n.sym->attr.optional > && formal_optional >@@ -3301,7 +3299,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) >@@ -3410,8 +3409,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; > } >@@ -4020,6 +4018,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 " >@@ -5390,7 +5395,7 @@ resolve_fl_derived (gfc_symbol *sym) > return FAILURE; > } > >- 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 115800) >+++ gcc/fortran/trans-decl.c (working copy) >@@ -945,6 +945,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) >@@ -2587,13 +2590,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); >@@ -2829,10 +2838,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; > >@@ -2992,7 +3003,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) > { >@@ -3007,7 +3017,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 > { >@@ -3018,6 +3039,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 115800) >+++ gcc/fortran/parse.c (working copy) >@@ -1500,6 +1500,7 @@ parse_derived (void) > gfc_statement st; > gfc_component *c; > gfc_state_data s; >+ gfc_symbol *sym; > > error_flag = 0; > >@@ -1610,6 +1611,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 115800) >+++ gcc/fortran/check.c (working copy) >@@ -461,13 +461,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, >@@ -1763,6 +1766,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 115800) >+++ 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 115800) >+++ 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 115800) >+++ libgfortran/Makefile.in (working copy) >@@ -166,8 +166,8 @@ am__objects_30 = associated.lo abort.lo > ctime.lo date_and_time.lo env.lo erf.lo eoshift0.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 \ >+ kill.lo ierrno.lo ishftc.lo link.lo malloc.lo move_alloc.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 \ >@@ -415,6 +415,7 @@ intrinsics/ierrno.c \ > intrinsics/ishftc.c \ > intrinsics/link.c \ > intrinsics/malloc.c \ >+intrinsics/move_alloc.c \ > intrinsics/mvbits.c \ > intrinsics/pack_generic.c \ > intrinsics/perror.c \ >@@ -2294,6 +2295,9 @@ link.lo: intrinsics/link.c > malloc.lo: intrinsics/malloc.c > $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o malloc.lo `test -f 'intrinsics/malloc.c' || echo '$(srcdir)/'`intrinsics/malloc.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 >+ > 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 > >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 115800) >+++ libgfortran/Makefile.am (working copy) >@@ -71,6 +71,7 @@ intrinsics/ierrno.c \ > intrinsics/ishftc.c \ > intrinsics/link.c \ > intrinsics/malloc.c \ >+intrinsics/move_alloc.c \ > intrinsics/mvbits.c \ > intrinsics/pack_generic.c \ > intrinsics/perror.c \
<b>You cannot view the attachment while viewing its details because your browser does not support IFRAMEs. <a href="attachment.cgi?id=11975">View the attachment on a separate page</a>.</b>
View Attachment As Diff
View Attachment As Raw
Actions:
View
|
Diff
Attachments on
bug 20541
:
11867
|
11871
|
11910
|
11975
|
12049
|
12060
|
12106
|
12313
|
12320
|
12350
|
12354
|
12373