GCC Bugzilla – Attachment 12350 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]
The latest version, incorporating all fixes so far.
alloc_comps0928.diff (text/plain), 79.00 KB, created by
Paul Thomas
on 2006-09-28 14:06:57 UTC
(
hide
)
Description:
The latest version, incorporating all fixes so far.
Filename:
MIME Type:
Creator:
Paul Thomas
Created:
2006-09-28 14:06:57 UTC
Size:
79.00 KB
patch
obsolete
>Index: gcc/fortran/interface.c >=================================================================== >--- gcc/fortran/interface.c (revision 117054) >+++ gcc/fortran/interface.c (working copy) >@@ -374,6 +374,9 @@ > if (dt1->dimension != dt2->dimension) > return 0; > >+ if (dt1->allocatable != dt2->allocatable) >+ return 0; >+ > if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) > return 0; > >Index: gcc/fortran/intrinsic.c >=================================================================== >--- gcc/fortran/intrinsic.c (revision 117054) >+++ gcc/fortran/intrinsic.c (working copy) >@@ -2391,6 +2391,11 @@ > length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL, > trim_name, BT_LOGICAL, dl, OPTIONAL); > >+ add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003, >+ gfc_check_move_alloc, NULL, NULL, >+ f, BT_UNKNOWN, 0, REQUIRED, >+ t, BT_UNKNOWN, 0, REQUIRED); >+ > add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95, > gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits, > f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED, >Index: gcc/fortran/trans-array.c >=================================================================== >--- gcc/fortran/trans-array.c (revision 117054) >+++ gcc/fortran/trans-array.c (working copy) >@@ -3236,32 +3236,27 @@ > 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; > >- /* In Fortran 95, components can only contain pointers, so that, >- in ALLOCATE (foo%bar(2)), bar must be a pointer component. >- We test this by checking for ref->next. >- An implementation of TR 15581 would need to change this. */ >- >- if (ref) >- must_be_pointer = ref->next != NULL; >- else >- must_be_pointer = 0; >- > /* Find the last reference in the chain. */ > while (ref && ref->next != NULL) > { > gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); >+ 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) > { >@@ -3294,11 +3289,6 @@ > 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) >@@ -3325,6 +3315,17 @@ > 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); >+ } >+{tree signal; >+signal = gfc_create_var (gfc_array_index_type, "SIGNAL"); >+gfc_add_modify_expr (&se->pre, signal, gfc_index_one_node);} >+ > return true; > } > >@@ -3465,6 +3466,9 @@ > } > break; > >+ case EXPR_NULL: >+ return gfc_build_null_descriptor (type); >+ > default: > gcc_unreachable (); > } >@@ -4547,6 +4551,17 @@ > 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; >@@ -4595,25 +4610,322 @@ > 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); >+} >+ >+ >+/* This helper function calculates the size in words of a full array. */ > >+static tree >+get_full_array_size (stmtblock_t *block, tree decl, int rank) >+{ >+ tree idx; >+ tree nelems; >+ tree tmp; >+ idx = gfc_rank_cst[rank - 1]; >+ nelems = gfc_conv_descriptor_ubound (decl, idx); >+ tmp = gfc_conv_descriptor_lbound (decl, idx); >+ tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp); >+ tmp = build2 (PLUS_EXPR, gfc_array_index_type, >+ tmp, gfc_index_one_node); >+ tmp = gfc_evaluate_now (tmp, block); >+ >+ nelems = gfc_conv_descriptor_stride (decl, idx); >+ tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp); >+ return gfc_evaluate_now (tmp, block); >+} >+ >+ >+/* Allocate dest to the same size as src, and copy src -> dest. */ >+ >+tree >+gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) >+{ >+ tree tmp; >+ tree size; >+ tree nelems; >+ tree args; >+ tree null_cond; >+ tree null_data; >+ stmtblock_t block; >+ >+ /* If the source is null, set the destination to null. */ >+ gfc_init_block (&block); >+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); >+ null_data = gfc_finish_block (&block); >+ >+ gfc_init_block (&block); >+ >+ nelems = get_full_array_size (&block, src, rank); >+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, >+ TYPE_SIZE_UNIT (gfc_get_element_type (type))); >+ >+ /* Allocate memory to the destination. */ >+ tmp = gfc_chainon_list (NULL_TREE, size); >+ if (gfc_index_integer_kind == 4) >+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp); >+ else if (gfc_index_integer_kind == 8) >+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp); >+ else >+ gcc_unreachable (); >+ tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)), >+ tmp)); >+ gfc_conv_descriptor_data_set (&block, dest, tmp); >+ >+ /* We know the temporary and the value will be the same length, >+ so can use memcpy. */ >+ tmp = gfc_conv_descriptor_data_get (dest); >+ args = gfc_chainon_list (NULL_TREE, tmp); >+ tmp = gfc_conv_descriptor_data_get (src); >+ args = gfc_chainon_list (args, tmp); >+ args = gfc_chainon_list (args, size); >+ tmp = built_in_decls[BUILT_IN_MEMCPY]; >+ tmp = build_function_call_expr (tmp, args); >+ gfc_add_expr_to_block (&block, tmp); > tmp = gfc_finish_block (&block); > >- return tmp; >+ /* Null the destination if the source is null; otherwise do >+ the allocate and copy. */ >+ null_cond = gfc_conv_descriptor_data_get (src); >+ null_cond = convert (pvoid_type_node, null_cond); >+ null_cond = build2 (NE_EXPR, boolean_type_node, null_cond, >+ null_pointer_node); >+ return build3_v (COND_EXPR, null_cond, tmp, null_data); > } > > >-/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */ >+/* Recursively traverse an object of derived type, generating code to >+ deallocate, nullify or copy allocatable components. This is the work horse >+ function for the functions named in this enum. */ >+ >+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP}; >+ >+static tree >+structure_alloc_comps (gfc_symbol * der_type, tree decl, >+ tree dest, int rank, int purpose) >+{ >+ gfc_component *c; >+ gfc_loopinfo loop; >+ stmtblock_t fnblock; >+ stmtblock_t loopbody; >+ tree tmp; >+ tree comp; >+ tree dcmp; >+ tree nelems; >+ tree index; >+ tree var; >+ tree cdecl; >+ tree ctype; >+ tree vref, dref; >+ tree null_cond = NULL_TREE; >+ >+ gfc_init_block (&fnblock); >+ >+ /* If this an array of derived types with allocatable components >+ build a loop and recursively call this function. */ >+ if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE >+ || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) >+ { >+ tmp = gfc_conv_array_data (decl); >+ var = build_fold_indirect_ref (tmp); >+ >+ /* Get the number of elements - 1 and set the counter. */ >+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) >+ { >+ /* Use the descriptor for an allocatable array. Since this >+ is a full array reference, we only need the descriptor >+ information from dimension = rank. */ >+ tmp = get_full_array_size (&fnblock, decl, rank); >+ tmp = build2 (MINUS_EXPR, gfc_array_index_type, >+ tmp, gfc_index_one_node); >+ >+ null_cond = gfc_conv_descriptor_data_get (decl); >+ null_cond = build2 (NE_EXPR, boolean_type_node, null_cond, >+ build_int_cst (TREE_TYPE (tmp), 0)); >+ } >+ else >+ { >+ /* Otherwise use the TYPE_DOMAIN information. */ >+ tmp = array_type_nelts (TREE_TYPE (decl)); >+ tmp = fold_convert (gfc_array_index_type, tmp); >+ } >+ >+ /* Remember that this is, in fact, the no. of elements - 1. */ >+ nelems = gfc_evaluate_now (tmp, &fnblock); >+ index = gfc_create_var (gfc_array_index_type, "S"); >+ >+ /* Build the body of the loop. */ >+ gfc_init_block (&loopbody); >+ >+ vref = gfc_build_array_ref (var, index); >+ >+ if (purpose == COPY_ALLOC_COMP) >+ { >+ tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ >+ tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest)); >+ dref = gfc_build_array_ref (tmp, index); >+ tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); >+ } >+ else >+ tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose); >+ >+ gfc_add_expr_to_block (&loopbody, tmp); >+ >+ /* Build the loop and return. */ >+ gfc_init_loopinfo (&loop); >+ loop.dimen = 1; >+ loop.from[0] = gfc_index_zero_node; >+ loop.loopvar[0] = index; >+ loop.to[0] = nelems; >+ gfc_trans_scalarizing_loops (&loop, &loopbody); >+ gfc_add_block_to_block (&fnblock, &loop.pre); >+ >+ tmp = gfc_finish_block (&fnblock); >+ if (null_cond != NULL_TREE) >+ tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ()); >+ >+ return tmp; >+ } >+ >+ /* Otherwise, act on the components or recursively call self to >+ act on a chain of components. */ >+ for (c = der_type->components; c; c = c->next) >+ { >+ bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED) >+ && c->ts.derived->attr.alloc_comp; >+ cdecl = c->backend_decl; >+ ctype = TREE_TYPE (cdecl); >+ >+ switch (purpose) >+ { >+ case DEALLOCATE_ALLOC_COMP: >+ /* Do not deallocate the components of ultimate pointer >+ components. */ >+ if (cmp_has_alloc_comps && !c->pointer) >+ { >+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); >+ rank = c->as ? c->as->rank : 0; >+ tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, >+ rank, purpose); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ >+ if (c->allocatable) >+ { >+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); >+ tmp = gfc_trans_dealloc_allocated (comp); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ break; >+ >+ case NULLIFY_ALLOC_COMP: >+ if (c->pointer) >+ continue; >+ else if (c->allocatable) >+ { >+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); >+ gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); >+ } >+ else if (cmp_has_alloc_comps) >+ { >+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); >+ rank = c->as ? c->as->rank : 0; >+ tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE, >+ rank, purpose); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ break; >+ >+ case COPY_ALLOC_COMP: >+ if (c->pointer) >+ continue; >+ >+ /* We need source and destination components. */ >+ comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); >+ dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE); >+ dcmp = fold_convert (TREE_TYPE (comp), dcmp); >+ >+ if (c->allocatable && !cmp_has_alloc_comps) >+ { >+ tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ >+ if (cmp_has_alloc_comps) >+ { >+ rank = c->as ? c->as->rank : 0; >+ tmp = fold_convert (TREE_TYPE (dcmp), comp); >+ gfc_add_modify_expr (&fnblock, dcmp, tmp); >+ tmp = structure_alloc_comps (c->ts.derived, comp, dcmp, >+ rank, purpose); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ break; >+ >+ default: >+ gcc_unreachable (); >+ break; >+ } >+ } >+ >+ return gfc_finish_block (&fnblock); >+} >+ >+/* Recursively traverse an object of derived type, generating code to >+ nullify allocatable components. */ >+ >+tree >+gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank) >+{ >+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank, >+ NULLIFY_ALLOC_COMP); >+} >+ >+ >+/* Recursively traverse an object of derived type, generating code to >+ deallocate allocatable components. */ >+ >+tree >+gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) >+{ >+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank, >+ DEALLOCATE_ALLOC_COMP); >+} >+ >+ >+/* Recursively traverse an object of derived type, generating code to >+ copy its allocatable components. */ >+ >+tree >+gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) >+{ >+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP); >+} >+ >+ >+/* NULLIFY an allocatable/pointer array on function entry, free it on exit. >+ Do likewise, recursively if necessary, with the allocatable components of >+ derived types. */ > > tree > gfc_trans_deferred_array (gfc_symbol * sym, tree body) >@@ -4623,16 +4935,22 @@ > tree descriptor; > stmtblock_t fnblock; > locus loc; >+ int rank; >+ bool sym_has_alloc_comp; >+ >+ sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) >+ && sym->ts.derived->attr.alloc_comp; > > /* Make sure the frontend gets these right. */ >- if (!(sym->attr.pointer || sym->attr.allocatable)) >- fatal_error >- ("Possible frontend bug: Deferred array size without pointer or allocatable attribute."); >+ if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) >+ fatal_error ("Possible frontend bug: Deferred array size without pointer, " >+ "allocatable attribute or derived type without allocatable " >+ "components."); > > gfc_init_block (&fnblock); > > gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL >- || TREE_CODE (sym->backend_decl) == PARM_DECL); >+ || TREE_CODE (sym->backend_decl) == PARM_DECL); > > if (sym->ts.type == BT_CHARACTER > && !INTEGER_CST_P (sym->ts.cl->backend_decl)) >@@ -4653,7 +4971,10 @@ > gfc_set_backend_locus (&sym->declared_at); > descriptor = sym->backend_decl; > >- if (TREE_STATIC (descriptor)) >+ /* Although static, derived types with deafult initializers and >+ allocatable components must not be nulled wholesale; instead they >+ are treated component by component. */ >+ if (TREE_STATIC (descriptor) && !sym_has_alloc_comp) > { > /* SAVEd variables are not freed on exit. */ > gfc_trans_static_array_pointer (sym); >@@ -4662,22 +4983,40 @@ > > /* Get the descriptor type. */ > type = TREE_TYPE (sym->backend_decl); >- if (!GFC_DESCRIPTOR_TYPE_P (type)) >+ >+ if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) >+ { >+ rank = sym->as ? sym->as->rank : 0; >+ tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ else if (!GFC_DESCRIPTOR_TYPE_P (type)) > { > /* If the backend_decl is not a descriptor, we must have a pointer > to one. */ > descriptor = build_fold_indirect_ref (sym->backend_decl); > type = TREE_TYPE (descriptor); >- 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_has_alloc_comp && !(sym->attr.function || sym->attr.result) >+ && !sym->attr.pointer) >+ { >+ int rank; >+ rank = sym->as ? sym->as->rank : 0; >+ tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank); >+ gfc_add_expr_to_block (&fnblock, tmp); >+ } >+ > if (sym->attr.allocatable) > { > tmp = gfc_trans_dealloc_allocated (sym->backend_decl); >Index: gcc/fortran/trans-expr.c >=================================================================== >--- gcc/fortran/trans-expr.c (revision 117054) >+++ gcc/fortran/trans-expr.c (working copy) >@@ -1701,7 +1701,7 @@ > > 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); >@@ -1792,7 +1792,7 @@ > > 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. */ >@@ -1864,6 +1864,7 @@ > gfc_ss *argss; > gfc_ss_info *info; > int byref; >+ int parm_kind; > tree type; > tree var; > tree len; >@@ -1877,6 +1878,7 @@ > gfc_expr *e; > gfc_symbol *fsym; > stmtblock_t post; >+ enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; > > arglist = NULL_TREE; > retargs = NULL_TREE; >@@ -1919,6 +1921,7 @@ > { > e = arg->expr; > fsym = formal ? formal->sym : NULL; >+ parm_kind = MISSING; > if (e == NULL) > { > >@@ -1947,6 +1950,7 @@ > /* An elemental function inside a scalarized loop. */ > gfc_init_se (&parmse, se); > gfc_conv_expr_reference (&parmse, e); >+ parm_kind = ELEMENTAL; > } > else > { >@@ -1957,12 +1961,14 @@ > 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); > } > } >@@ -2039,6 +2045,49 @@ > parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl; > } > >+ /* Allocated allocatable components of derived types must be >+ deallocated for INTENT(OUT) dummy arguments and non-variable >+ scalars. Non-variable arrays are dealt with in trans-array.c >+ (gfc_conv_array_parameter). */ >+ if (e && e->ts.type == BT_DERIVED >+ && e->ts.derived->attr.alloc_comp >+ && ((formal && formal->sym->attr.intent == INTENT_OUT) >+ || >+ (e->expr_type != EXPR_VARIABLE && !e->rank))) >+ { >+ int parm_rank; >+ tmp = build_fold_indirect_ref (parmse.expr); >+ parm_rank = e->rank; >+ switch (parm_kind) >+ { >+ case (ELEMENTAL): >+ case (SCALAR): >+ parm_rank = 0; >+ break; >+ >+ case (SCALAR_POINTER): >+ tmp = build_fold_indirect_ref (tmp); >+ break; >+ case (ARRAY): >+ tmp = parmse.expr; >+ break; >+ } >+ >+ tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); >+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) >+ tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym), >+ tmp, build_empty_stmt ()); >+ >+ if (e->expr_type != EXPR_VARIABLE) >+ /* Don't deallocate non-variables until they have been used. */ >+ gfc_add_expr_to_block (&se->post, tmp); >+ else >+ { >+ gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT); >+ gfc_add_expr_to_block (&se->pre, tmp); >+ } >+ } >+ > /* Character strings are passed as two parameters, a length and a > pointer. */ > if (parmse.string_length != NULL_TREE) >@@ -2625,7 +2674,7 @@ > > 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); >@@ -2646,17 +2695,22 @@ > return gfc_finish_block (&block); > } > >+ > /* Assign a single component of a derived type constructor. */ > > static tree > gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) > { > gfc_se se; >+ gfc_se lse; > gfc_ss *rss; > stmtblock_t block; > tree tmp; >+ tree offset; >+ int n; > > gfc_start_block (&block); >+ > if (cm->pointer) > { > gfc_init_se (&se, NULL); >@@ -2689,8 +2743,68 @@ > } > 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); >+ >+ rss = gfc_walk_expr (expr); >+ se.want_pointer = 0; >+ gfc_conv_expr_descriptor (&se, expr, rss); >+ gfc_add_block_to_block (&block, &se.pre); >+ >+ tmp = fold_convert (TREE_TYPE (dest), se.expr); >+ gfc_add_modify_expr (&block, dest, tmp); >+ >+ if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp) >+ tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest, >+ cm->as->rank); >+ else >+ tmp = gfc_duplicate_allocatable (dest, se.expr, >+ TREE_TYPE(cm->backend_decl), >+ cm->as->rank); >+ >+ gfc_add_expr_to_block (&block, tmp); >+ >+ gfc_add_block_to_block (&block, &se.post); >+ gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node); >+ >+ /* Shift the lbound and ubound of temporaries to being unity, rather >+ than zero, based. Calculate the offset for all cases. */ >+ offset = gfc_conv_descriptor_offset (dest); >+ gfc_add_modify_expr (&block, offset, gfc_index_zero_node); >+ tmp2 =gfc_create_var (gfc_array_index_type, NULL); >+ for (n = 0; n < expr->rank; n++) >+ { >+ if (expr->expr_type != EXPR_VARIABLE >+ && expr->expr_type != EXPR_CONSTANT) >+ { >+ tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]); >+ gfc_add_modify_expr (&block, tmp, >+ fold_build2 (PLUS_EXPR, >+ gfc_array_index_type, >+ tmp, gfc_index_one_node)); >+ tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]); >+ gfc_add_modify_expr (&block, tmp, gfc_index_one_node); >+ } >+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, >+ gfc_conv_descriptor_lbound (dest, >+ gfc_rank_cst[n]), >+ gfc_conv_descriptor_stride (dest, >+ gfc_rank_cst[n])); >+ gfc_add_modify_expr (&block, tmp2, tmp); >+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); >+ gfc_add_modify_expr (&block, offset, tmp); >+ } >+ } >+ else >+ { >+ tmp = gfc_trans_subarray_assign (dest, cm, expr); >+ gfc_add_expr_to_block (&block, tmp); >+ } > } > else if (expr->ts.type == BT_DERIVED) > { >@@ -2711,8 +2825,6 @@ > else > { > /* Scalar component. */ >- gfc_se lse; >- > gfc_init_se (&se, NULL); > gfc_init_se (&lse, NULL); > >@@ -2720,7 +2832,7 @@ > 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); >@@ -2780,12 +2892,16 @@ > } > > cm = expr->ts.derived->components; >+ > for (c = expr->value.constructor; c; c = c->next, cm = cm->next) > { >- /* Skip absent members in default initializers. */ >+ /* Skip absent members in default initializers and allocatable >+ components. */ > if (!c->expr) > continue; > >+ gcc_assert (!cm->allocatable); >+ > val = gfc_conv_initializer (c->expr, &cm->ts, > TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer); > >@@ -3078,16 +3194,19 @@ > > > /* Generate code for assignment of scalar variables. Includes character >- strings. */ >+ strings and derived types with allocatable components. */ > > 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); >@@ -3101,6 +3220,50 @@ > gfc_trans_string_copy (&block, lse->string_length, lse->expr, > rse->string_length, rse->expr); > } >+ else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp) >+ { >+ cond = NULL_TREE; >+ >+ /* Are the rhs and the lhs the same? */ >+ if (r_is_var) >+ { >+ cond = fold_build2 (EQ_EXPR, boolean_type_node, >+ build_fold_addr_expr (lse->expr), >+ build_fold_addr_expr (rse->expr)); >+ cond = gfc_evaluate_now (cond, &lse->pre); >+ } >+ >+ /* Deallocate the lhs allocated components as long as it is not >+ the same as the rhs. */ >+ if (!l_is_temp) >+ { >+ tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0); >+ if (r_is_var) >+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); >+ gfc_add_expr_to_block (&lse->pre, tmp); >+ } >+ >+ gfc_add_block_to_block (&block, &lse->pre); >+ gfc_add_block_to_block (&block, &rse->pre); >+ >+ gfc_add_modify_expr (&block, lse->expr, >+ fold_convert (TREE_TYPE (lse->expr), rse->expr)); >+ >+ /* Do a deep copy if the rhs is a variable, if it is not the >+ same as the lhs. Otherwise, nullify the data fields so that the >+ lhs retains the allocated resources. */ >+ if (r_is_var) >+ { >+ tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0); >+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp); >+ gfc_add_expr_to_block (&block, tmp); >+ } >+ else >+ { >+ tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0); >+ gfc_add_expr_to_block (&block, tmp); >+ } >+ } > else > { > gfc_add_block_to_block (&block, &lse->pre); >@@ -3206,6 +3369,7 @@ > tree tmp; > stmtblock_t block; > stmtblock_t body; >+ bool l_is_temp; > > /* Special case a single function returning an array. */ > if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) >@@ -3284,10 +3448,12 @@ > else > gfc_init_block (&body); > >+ l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); >+ > /* Translate the expression. */ > gfc_conv_expr (&rse, expr2); > >- if (lss != gfc_ss_terminator && loop.temp_ss != NULL) >+ if (l_is_temp) > { > gfc_conv_tmp_array_ref (&lse); > gfc_advance_se_ss_chain (&lse); >@@ -3295,7 +3461,8 @@ > 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, l_is_temp, >+ expr2->expr_type == EXPR_VARIABLE); > gfc_add_expr_to_block (&body, tmp); > > if (lss == gfc_ss_terminator) >@@ -3308,7 +3475,7 @@ > gcc_assert (lse.ss == gfc_ss_terminator > && rse.ss == gfc_ss_terminator); > >- if (loop.temp_ss != NULL) >+ if (l_is_temp) > { > gfc_trans_scalarized_loop_boundary (&loop, &body); > >@@ -3328,9 +3495,10 @@ > 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 117054) >+++ gcc/fortran/symbol.c (working copy) >@@ -1523,6 +1523,7 @@ > > c->dimension = attr->dimension; > c->pointer = attr->pointer; >+ c->allocatable = attr->allocatable; > } > > >@@ -1536,6 +1537,7 @@ > gfc_clear_attr (attr); > attr->dimension = c->dimension; > attr->pointer = c->pointer; >+ attr->allocatable = c->allocatable; > } > > >Index: gcc/fortran/intrinsic.h >=================================================================== >--- gcc/fortran/intrinsic.h (revision 117054) >+++ gcc/fortran/intrinsic.h (working copy) >@@ -153,6 +153,7 @@ > try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); > try gfc_check_gerror (gfc_expr *); > try gfc_check_getlog (gfc_expr *); >+try gfc_check_move_alloc (gfc_expr *, gfc_expr *); > try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, > gfc_expr *); > try gfc_check_random_number (gfc_expr *); >Index: gcc/fortran/decl.c >=================================================================== >--- gcc/fortran/decl.c (revision 117054) >+++ gcc/fortran/decl.c (working copy) >@@ -962,14 +962,31 @@ > > /* 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; > } > } >@@ -1284,6 +1301,14 @@ > } > } > >+ if (initializer != NULL && current_attr.allocatable >+ && gfc_current_state () == COMP_DERIVED) >+ { >+ gfc_error ("Initialization of allocatable component at %C is not allowed"); >+ m = MATCH_ERROR; >+ goto cleanup; >+ } >+ > /* Check if we are parsing an enumeration and if the current enumerator > variable has an initializer or not. If it does not have an > initializer, the initialization value of the previous enumerator >@@ -1315,8 +1340,10 @@ > t = add_init_expr_to_sym (name, &initializer, &var_locus); > else > { >- if (current_ts.type == BT_DERIVED && !current_attr.pointer >- && !initializer) >+ if (current_ts.type == BT_DERIVED >+ && !current_attr.pointer >+ && !current_attr.allocatable >+ && !initializer) > initializer = gfc_default_initializer (¤t_ts); > t = build_struct (name, cl, &initializer, &as); > } >@@ -2141,11 +2168,24 @@ > && 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 117054) >+++ gcc/fortran/trans-array.h (working copy) >@@ -43,6 +43,15 @@ > tree gfc_trans_g77_array (gfc_symbol *, tree); > /* Generate code to deallocate an array, if it is allocated. */ > tree gfc_trans_dealloc_allocated (tree); >+ >+tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank); >+ >+tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int); >+ >+tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int); >+ >+tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int); >+ > /* Add initialization for deferred arrays. */ > tree gfc_trans_deferred_array (gfc_symbol *, tree); > /* Generate an initializer for a static pointer or allocatable array. */ >Index: gcc/fortran/gfortran.texi >=================================================================== >--- gcc/fortran/gfortran.texi (revision 117054) >+++ gcc/fortran/gfortran.texi (working copy) >@@ -1370,7 +1370,8 @@ > @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 >@@ -1397,14 +1398,17 @@ > > @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 117054) >+++ gcc/fortran/gfortran.h (working copy) >@@ -532,6 +532,9 @@ > /* 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 @@ > const char *name; > gfc_typespec ts; > >- int pointer, dimension; >+ int pointer, allocatable, dimension; > gfc_array_spec *as; > > tree backend_decl; >@@ -1969,6 +1972,7 @@ > void gfc_free_actual_arglist (gfc_actual_arglist *); > gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); > const char *gfc_extract_int (gfc_expr *, int *); >+gfc_expr *gfc_expr_to_initialize (gfc_expr *); > > gfc_expr *gfc_build_conversion (gfc_expr *); > void gfc_free_ref_list (gfc_ref *); >Index: gcc/fortran/trans-stmt.c >=================================================================== >--- gcc/fortran/trans-stmt.c (revision 117054) >+++ gcc/fortran/trans-stmt.c (working copy) >@@ -1802,7 +1802,8 @@ > gfc_conv_expr (&lse, expr); > > /* Use the scalar assignment. */ >- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); >+ rse.string_length = lse.string_length; >+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); > > /* Form the mask expression according to the mask tree list. */ > if (wheremask) >@@ -1897,7 +1898,9 @@ > } > > /* Use the scalar assignment. */ >- tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); >+ lse.string_length = rse.string_length; >+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true, >+ expr2->expr_type == EXPR_VARIABLE); > > /* Form the mask expression according to the mask tree list. */ > if (wheremask) >@@ -2978,7 +2981,8 @@ > 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); >@@ -3031,7 +3035,7 @@ > 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); > >@@ -3406,8 +3410,8 @@ > 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); >@@ -3591,6 +3595,14 @@ > 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); >@@ -3675,6 +3687,26 @@ > 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 117054) >+++ gcc/fortran/module.c (working copy) >@@ -1435,7 +1435,7 @@ > 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,7 @@ > minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), > minit ("CRAY_POINTER", AB_CRAY_POINTER), > minit ("CRAY_POINTEE", AB_CRAY_POINTEE), >+ minit ("ALLOC_COMP", AB_ALLOC_COMP), > minit (NULL, -1) > }; > >@@ -1556,6 +1557,9 @@ > 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 +1648,9 @@ > case AB_CRAY_POINTEE: > attr->cray_pointee = 1; > break; >+ case AB_ALLOC_COMP: >+ attr->alloc_comp = 1; >+ break; > } > } > } >@@ -1951,6 +1958,7 @@ > > mio_integer (&c->dimension); > mio_integer (&c->pointer); >+ mio_integer (&c->allocatable); > > mio_expr (&c->initializer); > mio_rparen (); >Index: gcc/fortran/trans-types.c >=================================================================== >--- gcc/fortran/trans-types.c (revision 117054) >+++ gcc/fortran/trans-types.c (working copy) >@@ -1550,7 +1550,7 @@ > 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 117054) >+++ gcc/fortran/trans.h (working copy) >@@ -307,7 +307,7 @@ > /* 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 117054) >+++ gcc/fortran/resolve.c (working copy) >@@ -596,16 +596,24 @@ > > for (; comp; comp = comp->next, cons = cons->next) > { >- if (! cons->expr) >+ if (!cons->expr) >+ continue; >+ >+ if (gfc_resolve_expr (cons->expr) == FAILURE) > { > t = FAILURE; > continue; > } > >- if (gfc_resolve_expr (cons->expr) == FAILURE) >- { >+ if (cons->expr->expr_type != EXPR_NULL >+ && comp->as && comp->as->rank != cons->expr->rank >+ && (comp->allocatable || cons->expr->rank)) >+ { >+ gfc_error ("The rank of the element in the derived type " >+ "constructor at %L does not match that of the " >+ "component (%d/%d)", &cons->expr->where, >+ cons->expr->rank, comp->as ? comp->as->rank : 0); > t = FAILURE; >- continue; > } > > /* If we don't have the right type, try to convert it. */ >@@ -918,9 +926,9 @@ > } > > >-/* 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. */ >+ /* 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. */ > static try > resolve_elemental_actual (gfc_expr *expr, gfc_code *c) > { >@@ -973,7 +981,7 @@ > && 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; >@@ -3312,7 +3320,8 @@ > > /* 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) >@@ -3417,12 +3426,23 @@ > /* Add default initializer for those derived types that need them. */ > if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts))) > { >+ gfc_component *cm; >+ gfc_constructor *c; >+ >+ cm = e->ts.derived->components; >+ for (c = init_e->value.constructor; c; c = c->next, cm = cm->next) >+ if (cm->allocatable && c->expr == NULL) >+ { >+ c->expr = gfc_get_expr (); >+ c->expr->expr_type = EXPR_NULL; >+ c->expr->ts = cm->ts; >+ } >+ > init_st = gfc_get_code (); > 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; > } >@@ -4031,6 +4051,13 @@ > 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 " >@@ -5412,7 +5439,7 @@ > } > } > >- 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 117054) >+++ gcc/fortran/trans-decl.c (working copy) >@@ -957,6 +957,9 @@ > 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) >@@ -2559,6 +2562,8 @@ > > for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) > { >+ bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) >+ && sym->ts.derived->attr.alloc_comp; > if (sym->attr.dimension) > { > switch (sym->as->type) >@@ -2601,13 +2606,18 @@ > break; > > case AS_DEFERRED: >- fnbody = gfc_trans_deferred_array (sym, fnbody); >+ if (!sym_has_alloc_comp) >+ fnbody = gfc_trans_deferred_array (sym, fnbody); > break; > > default: > gcc_unreachable (); > } >+ if (sym_has_alloc_comp) >+ fnbody = gfc_trans_deferred_array (sym, fnbody); > } >+ else if (sym_has_alloc_comp) >+ fnbody = gfc_trans_deferred_array (sym, fnbody); > else if (sym->ts.type == BT_CHARACTER) > { > gfc_get_backend_locus (&loc); >@@ -2959,10 +2969,12 @@ > 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; > >@@ -3122,7 +3134,6 @@ > 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) > { >@@ -3137,7 +3148,18 @@ > 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 > { >@@ -3148,6 +3170,9 @@ > gfc_add_expr_to_block (&block, tmp); > } > } >+ else >+ gfc_add_expr_to_block (&block, tmp); >+ > > /* Add all the decls we created during processing. */ > decl = saved_function_decls; >Index: gcc/fortran/parse.c >=================================================================== >--- gcc/fortran/parse.c (revision 117054) >+++ gcc/fortran/parse.c (working copy) >@@ -1499,6 +1499,8 @@ > 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 @@ > } > } > >+ /* Look for allocatable components. */ >+ sym = gfc_current_block (); >+ for (c = sym->components; c; c = c->next) >+ { >+ if (c->allocatable || (c->ts.type == BT_DERIVED >+ && c->ts.derived->attr.alloc_comp)) >+ { >+ sym->attr.alloc_comp = 1; >+ break; >+ } >+ } >+ > pop_state (); > } > >Index: gcc/fortran/check.c >=================================================================== >--- gcc/fortran/check.c (revision 117054) >+++ gcc/fortran/check.c (working copy) >@@ -477,13 +477,16 @@ > 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 @@ > return SUCCESS; > } > >+try >+gfc_check_move_alloc (gfc_expr * from, gfc_expr * to) >+{ >+ symbol_attribute attr; >+ >+ if (variable_check (from, 0) == FAILURE) >+ return FAILURE; >+ >+ if (array_check (from, 0) == FAILURE) >+ return FAILURE; >+ >+ attr = gfc_variable_attr (from, NULL); >+ if (!attr.allocatable) >+ { >+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", >+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic, >+ &from->where); >+ return FAILURE; >+ } >+ >+ if (variable_check (to, 0) == FAILURE) >+ return FAILURE; >+ >+ if (array_check (to, 0) == FAILURE) >+ return FAILURE; >+ >+ attr = gfc_variable_attr (to, NULL); >+ if (!attr.allocatable) >+ { >+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", >+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic, >+ &to->where); >+ return FAILURE; >+ } >+ >+ if (same_type_check (from, 0, to, 1) == FAILURE) >+ return FAILURE; >+ >+ if (to->rank != from->rank) >+ { >+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " >+ "have the same rank %d/%d", gfc_current_intrinsic_arg[0], >+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, >+ &to->where, from->rank, to->rank); >+ return FAILURE; >+ } >+ >+ if (to->ts.kind != from->ts.kind) >+ { >+ gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " >+ "be of the same kind %d/%d", gfc_current_intrinsic_arg[0], >+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, >+ &to->where, from->ts.kind, to->ts.kind); >+ return FAILURE; >+ } >+ >+ return SUCCESS; >+} > > try > gfc_check_nearest (gfc_expr * x, gfc_expr * s) >Index: gcc/fortran/primary.c >=================================================================== >--- gcc/fortran/primary.c (revision 117054) >+++ gcc/fortran/primary.c (working copy) >@@ -1711,7 +1711,7 @@ > 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 @@ > > dimension = attr.dimension; > pointer = attr.pointer; >+ allocatable = attr.allocatable; > > target = attr.target; > if (pointer) >@@ -1743,12 +1744,12 @@ > 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 @@ > *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 117054) >+++ gcc/fortran/intrinsic.texi (working copy) >@@ -181,6 +181,7 @@ > * @code{MINVAL}: MINVAL, Minimum value of an array > * @code{MOD}: MOD, Remainder function > * @code{MODULO}: MODULO, Modulo function >+* @code{MOVE_ALLOC}: MOVE_ALLOC, Move allocation from one object to another > * @code{MVBITS}: MVBITS, Move bits from one integer to another > * @code{NEAREST}: NEAREST, Nearest representable number > * @code{NINT}: NINT, Nearest whole number >@@ -5833,6 +5834,50 @@ > > > >+@node MOVE_ALLOC >+@section @code{MOVE_ALLOC} --- Move allocation from one object to another >+@findex @code{MOVE_ALLOC} intrinsic >+@cindex MOVE_ALLOC >+ >+@table @asis >+@item @emph{Description}: >+@code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to >+@var{DEST}. @var{SRC} will become deallocated in the process. >+ >+@item @emph{Option}: >+f2003, gnu >+ >+@item @emph{Class}: >+Subroutine >+ >+@item @emph{Syntax}: >+@code{CALL MOVE_ALLOC(SRC, DEST)} >+ >+@item @emph{Arguments}: >+@multitable @columnfractions .15 .80 >+@item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind. >+@item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC} >+@end multitable >+ >+@item @emph{Return value}: >+None >+ >+@item @emph{Example}: >+@smallexample >+program test_move_alloc >+ integer, allocatable :: a(:), b(:) >+ >+ allocate(a(3)) >+ a = [ 1, 2, 3 ] >+ call move_alloc(a, b) >+ print *, allocated(a), allocated(b) >+ print *, b >+end program test_move_alloc >+@end smallexample >+@end table >+ >+ >+ > @node NEAREST > @section @code{NEAREST} --- Nearest representable number > @findex @code{NEAREST} intrinsic >Index: libgfortran/Makefile.in >=================================================================== >--- libgfortran/Makefile.in (revision 117054) >+++ libgfortran/Makefile.in (working copy) >@@ -167,12 +167,12 @@ > 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 @@ > AUTOMAKE = @AUTOMAKE@ > AWK = @AWK@ > CC = @CC@ >+CFLAGS = @CFLAGS@ > CPP = @CPP@ > CPPFLAGS = @CPPFLAGS@ > CYGPATH_W = @CYGPATH_W@ >@@ -276,6 +277,7 @@ > 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 @@ > 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_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_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/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 @@ > 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 117054) >+++ libgfortran/Makefile.am (working copy) >@@ -74,6 +74,7 @@ > intrinsics/link.c \ > intrinsics/malloc.c \ > intrinsics/mvbits.c \ >+intrinsics/move_alloc.c \ > intrinsics/pack_generic.c \ > intrinsics/perror.c \ > intrinsics/signal.c \ >Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90 (revision 0) >@@ -0,0 +1,57 @@ >+! { dg-do run } >+! Test assignments of derived type with allocatable components (PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ type :: ivs >+ character(1), allocatable :: chars(:) >+ end type ivs >+ >+ type(ivs) :: a, b >+ type(ivs) :: x(3), y(3) >+ >+ allocate(a%chars(5)) >+ a%chars = (/"h","e","l","l","o"/) >+ >+! An intrinsic assignment must deallocate the l-value and copy across >+! the array from the r-value. >+ b = a >+ if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort () >+ if (allocated (a%chars) .eqv. .false.) call abort () >+ >+! Scalar to array needs to copy the derived type, to its ultimate components, >+! to each of the l-value elements. */ >+ x = b >+ x(2)%chars = (/"g","'","d","a","y"/) >+ if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort () >+ if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (allocated (b%chars) .eqv. .false.) call abort () >+ deallocate (x(1)%chars, x(2)%chars, x(3)%chars) >+ >+! Array intrinsic assignments are like their scalar counterpart and >+! must deallocate each element of the l-value and copy across the >+! arrays from the r-value elements. >+ allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5)) >+ x(1)%chars = (/"h","e","l","l","o"/) >+ x(2)%chars = (/"g","'","d","a","y"/) >+ x(3)%chars = (/"g","o","d","a","g"/) >+ y(2:1:-1) = x(1:2) >+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort () >+ if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort () >+ >+! In the case of an assignment where there is a dependency, so that a >+! temporary is necessary, each element must be copied to its >+! destination after it has been deallocated. >+ y(2:3) = y(1:2) >+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort () >+ >+! An identity assignment must not do any deallocation....! >+ y = y >+ if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort () >+ if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort () >+end >Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_basics_3.f90 (revision 0) >@@ -0,0 +1,15 @@ >+ type :: a >+ integer, allocatable :: i(:) >+ end type a >+ >+ >+ type :: c >+ integer, allocatable :: i(:) >+ end type c >+ >+ type (c) :: x >+ >+ print *, x%i(1) >+ >+end >+ >Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90 (revision 0) >@@ -0,0 +1,57 @@ >+! { dg-do run } >+! Test FORALL and WHERE with derived types with allocatable components (PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ type :: a >+ integer, allocatable :: i(:) >+ end type a >+ >+ type :: b >+ type (a), allocatable :: at(:) >+ end type b >+ >+ type(a) :: x(2) >+ type(b) :: y(2), z(2) >+ integer i, m(4) >+ >+! Start with scalar and array element assignments in FORALL. >+ >+ x(1) = a ((/1, 2, 3, 4/)) >+ x(2) = a ((/1, 2, 3, 4/) + 10) >+ forall (j = 1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10) x(j)%i(i) = j*4-i >+ if (any ((/((x(i)%i(j), j = 1,4), i = 1,2)/) .ne. & >+ (/1, 2, 1, 0, 11, 12, 5, 4/))) call abort () >+ >+ y(1) = b ((/x(1),x(2)/)) >+ y(2) = b ((/x(2),x(1)/)) >+ forall (k = 1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10) >+ y(k)%at(j)%i(i) = j*4-i+k >+ end forall >+ if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & >+ (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () >+ >+! Now simple assignments in WHERE. >+ >+ where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0 >+ if (any( (/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & >+ (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () >+ >+ where (y((2))%at(:)%i(2) > 8) >+ y(2)%at(:)%i(2) = 77 >+ end where >+ if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & >+ (/0,0,2,1,11,12,6,5,11,77,3,2,9,8,7,6/))) call abort () >+ >+! Check that temporaries and full array alloctable component assignments >+! are correctly handled in FORALL. >+ >+ x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/) >+ forall (i=1:2) y(i) = b ((/x(i)/)) >+ forall (i=1:2) y(i) = y(3-i) ! This needs a temporary. >+ forall (i=1:2) z(i) = y(i) >+ if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. & >+ (/(/5,6,7,8/),(/1,2,3,4/)/))) call abort () >+ >+end >Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90 (revision 0) >@@ -0,0 +1,36 @@ >+! { dg-do run } >+! Test assignments of nested derived types with allocatable components(PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ type :: a >+ integer, allocatable :: i(:) >+ end type a >+ >+ type :: b >+ type (a), allocatable :: at(:) >+ end type b >+ >+ type(a) :: x(2) >+ type(b) :: y(2), z(2) >+ integer i, m(4) >+ >+ x(1) = a((/1,2,3,4/)) >+ x(2) = a((/1,2,3,4/)+10) >+ >+ y(1) = b((/x(1),x(2)/)) >+ y(2) = b((/x(2),x(1)/)) >+ >+ y(2) = y(1) >+ forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) & >+ y(1)%at(j)%i(k) = 999 >+ if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) call abort () >+ >+ >+ z = y >+ forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) & >+ z(i)%at(j)%i(k) = 999 >+ if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) call abort () >+ >+end >Index: gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90 (revision 0) >@@ -0,0 +1,71 @@ >+! { dg-do run } >+! This checks the correct functioning of derived types with default initializers >+! and allocatable components. >+! >+! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it> >+! >+module p_type_mod >+ >+ type m_type >+ integer, allocatable :: p(:) >+ end type m_type >+ >+ type basep_type >+ type(m_type), allocatable :: av(:) >+ type(m_type), pointer :: ap => null () >+ integer :: i = 101 >+ end type basep_type >+ >+ type p_type >+ type(basep_type), allocatable :: basepv(:) >+ integer :: p1 , p2 = 1 >+ end type p_type >+end module p_type_mod >+ >+program foo >+ >+ use p_type_mod >+ implicit none >+ >+ type(m_type), target :: a >+ type(p_type) :: pre >+ type(basep_type) :: wee >+ >+ call test_ab8 () >+ >+ a = m_type ((/101,102/)) >+ >+ call p_bld (a, pre) >+ >+ if (associated (wee%ap) .or. wee%i /= 101) call abort () >+ wee%ap => a >+ if (.not.associated (wee%ap) .or. allocated (wee%av)) call abort () >+ wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99) >+ if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) call abort () >+ >+contains >+ >+! Check that allocatable components are nullified after allocation. >+ subroutine test_ab8 () >+ type(p_type) :: p >+ integer :: ierr >+ >+ if (.not.allocated(p%basepv)) then >+ allocate(p%basepv(1),stat=ierr) >+ endif >+ if (allocated (p%basepv) .neqv. .true.) call abort () >+ if (allocated (p%basepv(1)%av) .neqv. .false.) call abort >+ if (p%basepv(1)%i .ne. 101) call abort () >+ >+ end subroutine test_ab8 >+ >+ subroutine p_bld (a, p) >+ use p_type_mod >+ type (m_type) :: a >+ type(p_type) :: p >+ if (any (a%p .ne. (/101,102/))) call abort () >+ if (allocated (p%basepv) .or. (p%p2 .ne. 1)) call abort () >+ end subroutine p_bld >+ >+end program foo >+! { dg-final { cleanup-modules "p_type_mod" } } >Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90 (revision 0) >@@ -0,0 +1,63 @@ >+! { dg-do run } >+! Test assignments of nested derived types with character allocatable >+! components(PR 20541). Subroutine test_ab6 checks out a bug in a test >+! version of gfortran's allocatable arrays. >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ type :: a >+ character(4), allocatable :: ch(:) >+ end type a >+ >+ type :: b >+ type (a), allocatable :: at(:) >+ end type b >+ >+ type(a) :: x(2) >+ type(b) :: y(2), z(2) >+ >+ character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/) >+ character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/) >+ >+ x(1) = a(chr1) >+ >+ ! Check constructor with character array constructors. >+ x(2) = a((/"qrst","uvwx","yz12","3456"/)) >+ >+ y(1) = b((/x(1),x(2)/)) >+ y(2) = b((/x(2),x(1)/)) >+ >+ y(2) = y(1) >+ >+ if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. & >+ (/chr1, chr2/))) call abort () >+ >+ call test_ab6 () >+ >+contains >+ >+ subroutine test_ab6 () >+! This subroutine tests the presence of a scalar derived type, intermediate >+! in a chain of derived types with allocatable components. >+! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it> >+ >+ type b >+ type(a) :: a >+ end type b >+ >+ type c >+ type(b), allocatable :: b(:) >+ end type c >+ >+ type(c) :: p >+ type(b) :: bv >+ >+ p = c((/b(a((/"Mary","Lamb"/)))/)) >+ bv = p%b(1) >+ >+ if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) call abort () >+ >+end subroutine test_ab6 >+ >+end >Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 (revision 0) >@@ -0,0 +1,108 @@ >+! { dg-do run } >+! { dg-options "-fdump-tree-original" } >+! Test constructors of derived type with allocatable components (PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ >+Program test_constructor >+ >+ implicit none >+ >+ type :: thytype >+ integer(4) :: a(2,2) >+ end type thytype >+ >+ type :: mytype >+ integer(4), allocatable :: a(:, :) >+ type(thytype), allocatable :: q(:) >+ end type mytype >+ >+ type (mytype) :: x >+ type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) >+ integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2]) >+ integer, allocatable :: yy(:,:) >+ type (thytype), allocatable :: bar(:) >+ integer :: i >+ >+ ! Check that null() works >+ x = mytype(null(), null()) >+ if (allocated(x%a) .or. allocated(x%q)) call abort() >+ >+ ! Check that unallocated allocatables work >+ x = mytype(yy, bar) >+ if (allocated(x%a) .or. allocated(x%q)) call abort() >+ >+ ! Check that non-allocatables work >+ x = mytype(y, [foo, foo]) >+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() >+ if (any(lbound(x%a) /= lbound(y))) call abort() >+ if (any(ubound(x%a) /= ubound(y))) call abort() >+ if (any(x%a /= y)) call abort() >+ if (size(x%q) /= 2) call abort() >+ do i = 1, 2 >+ if (any(x%q(i)%a /= foo%a)) call abort() >+ end do >+ >+ ! Check that allocated allocatables work >+ allocate(yy(size(y,1), size(y,2))) >+ yy = y >+ allocate(bar(2)) >+ bar = [foo, foo] >+ x = mytype(yy, bar) >+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() >+ if (any(x%a /= y)) call abort() >+ if (size(x%q) /= 2) call abort() >+ do i = 1, 2 >+ if (any(x%q(i)%a /= foo%a)) call abort() >+ end do >+ >+ ! Functions returning arrays >+ x = mytype(bluhu(), null()) >+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort() >+ if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort() >+ >+ ! Functions returning allocatable arrays >+ x = mytype(blaha(), null()) >+ if (.not.allocated(x%a) .or. allocated(x%q)) call abort() >+ if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort() >+ >+ ! Check that passing the constructor to a procedure works >+ call check_mytype (mytype(y, [foo, foo])) >+ >+contains >+ >+ subroutine check_mytype(x) >+ type(mytype), intent(in) :: x >+ integer :: i >+ >+ if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort() >+ if (any(lbound(x%a) /= lbound(y))) call abort() >+ if (any(ubound(x%a) /= ubound(y))) call abort() >+ if (any(x%a /= y)) call abort() >+ if (size(x%q) /= 2) call abort() >+ do i = 1, 2 >+ if (any(x%q(i)%a /= foo%a)) call abort() >+ end do >+ >+ end subroutine check_mytype >+ >+ >+ function bluhu() >+ integer :: bluhu(2,2) >+ >+ bluhu = reshape ([41, 98, 54, 76], [2,2]) >+ end function bluhu >+ >+ >+ function blaha() >+ integer, allocatable :: blaha(:,:) >+ >+ allocate(blaha(2,2)) >+ blaha = reshape ([40, 97, 53, 75], [2,2]) >+ end function blaha >+ >+end program test_constructor >+! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } } >+! { dg-final { cleanup-tree-dump "original" } } >Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90 (revision 0) >@@ -0,0 +1,26 @@ >+! { dg-do run } >+! Test constructors of nested derived types with allocatable components(PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+ type :: thytype >+ integer(4), allocatable :: h(:) >+ end type thytype >+ >+ type :: mytype >+ type(thytype), allocatable :: q(:) >+ end type mytype >+ >+ type (mytype) :: x >+ type (thytype) :: w(2) >+ integer :: y(2) =(/1,2/) >+ >+ w = (/thytype(y), thytype (2*y)/) >+ x = mytype (w) >+ if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort () >+ >+ x = mytype ((/thytype(3*y), thytype (4*y)/)) >+ if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort () >+ >+end >Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 0) >@@ -0,0 +1,143 @@ >+! { dg-do run} >+! { dg-options "-O2 -fdump-tree-original" } >+! >+! Check some basic functionality of allocatable components, including that they >+! are nullified when created and automatically deallocated when >+! 1. A variable goes out of scope >+! 2. INTENT(OUT) dummies >+! 3. Function results >+! >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+module alloc_m >+ >+ implicit none >+ >+ type :: alloc1 >+ real, allocatable :: x(:) >+ end type alloc1 >+ >+end module alloc_m >+ >+ >+program alloc >+ >+ use alloc_m >+ >+ implicit none >+ >+ type :: alloc2 >+ type(alloc1), allocatable :: a1(:) >+ integer, allocatable :: a2(:) >+ end type alloc2 >+ >+ type(alloc2) :: b >+ integer :: i >+ type(alloc2), allocatable :: c(:) >+ >+ if (allocated(b%a2) .OR. allocated(b%a1)) then >+ write (0, *) 'main - 1' >+ call abort() >+ end if >+ >+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) >+ call allocate_alloc2(b) >+ call check_alloc2(b) >+ >+ do i = 1, size(b%a1) >+ ! 1 call to _gfortran_deallocate >+ deallocate(b%a1(i)%x) >+ end do >+ >+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) >+ call allocate_alloc2(b) >+ >+ call check_alloc2(return_alloc2()) >+ ! 3 calls to _gfortran_deallocate (function result) >+ >+ allocate(c(1)) >+ ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) >+ call allocate_alloc2(c(1)) >+ ! 4 calls to _gfortran_deallocate >+ deallocate(c) >+ >+ ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope) >+ >+contains >+ >+ subroutine allocate_alloc2(b) >+ type(alloc2), intent(out) :: b >+ integer :: i >+ >+ if (allocated(b%a2) .OR. allocated(b%a1)) then >+ write (0, *) 'allocate_alloc2 - 1' >+ call abort() >+ end if >+ >+ allocate (b%a2(3)) >+ b%a2 = [ 1, 2, 3 ] >+ >+ allocate (b%a1(3)) >+ >+ do i = 1, 3 >+ if (allocated(b%a1(i)%x)) then >+ write (0, *) 'allocate_alloc2 - 2', i >+ call abort() >+ end if >+ allocate (b%a1(i)%x(3)) >+ b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] >+ end do >+ >+ end subroutine allocate_alloc2 >+ >+ >+ type(alloc2) function return_alloc2() result(b) >+ if (allocated(b%a2) .OR. allocated(b%a1)) then >+ write (0, *) 'return_alloc2 - 1' >+ call abort() >+ end if >+ >+ allocate (b%a2(3)) >+ b%a2 = [ 1, 2, 3 ] >+ >+ allocate (b%a1(3)) >+ >+ do i = 1, 3 >+ if (allocated(b%a1(i)%x)) then >+ write (0, *) 'return_alloc2 - 2', i >+ call abort() >+ end if >+ allocate (b%a1(i)%x(3)) >+ b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] >+ end do >+ end function return_alloc2 >+ >+ >+ subroutine check_alloc2(b) >+ type(alloc2), intent(in) :: b >+ >+ if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then >+ write (0, *) 'check_alloc2 - 1' >+ call abort() >+ end if >+ if (any(b%a2 /= [ 1, 2, 3 ])) then >+ write (0, *) 'check_alloc2 - 2' >+ call abort() >+ end if >+ do i = 1, 3 >+ if (.NOT.allocated(b%a1(i)%x)) then >+ write (0, *) 'check_alloc2 - 3', i >+ call abort() >+ end if >+ if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then >+ write (0, *) 'check_alloc2 - 4', i >+ call abort() >+ end if >+ end do >+ end subroutine check_alloc2 >+ >+end program alloc >+! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } } >+! { dg-final { cleanup-tree-dump "original" } } >Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 >=================================================================== >--- gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0) >+++ gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90 (revision 0) >@@ -0,0 +1,39 @@ >+! { dg-do run } >+! Check "double" allocations of allocatable components (PR 20541). >+! >+! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org> >+! and Paul Thomas <pault@gcc.gnu.org> >+! >+program main >+ >+ implicit none >+ >+ type foo >+ integer, dimension(:), allocatable :: array >+ end type foo >+ >+ type(foo),allocatable,dimension(:) :: mol >+ type(foo),pointer,dimension(:) :: molp >+ integer :: i >+ >+ allocate (mol(1)) >+ allocate (mol(1), stat=i) >+ !print *, i ! /= 0 >+ if (i == 0) call abort() >+ >+ allocate (mol(1)%array(5)) >+ allocate (mol(1)%array(5),stat=i) >+ !print *, i ! /= 0 >+ if (i == 0) call abort() >+ >+ allocate (molp(1)) >+ allocate (molp(1), stat=i) >+ !print *, i ! == 0 >+ if (i /= 0) call abort() >+ >+ allocate (molp(1)%array(5)) >+ allocate (molp(1)%array(5),stat=i) >+ !print *, i ! /= 0 >+ if (i == 0) call abort() >+ >+end program main
<b>You cannot view the attachment while viewing its details because your browser does not support IFRAMEs. <a href="attachment.cgi?id=12350">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