Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 166125) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3353,3360 **** se->expr = build_fold_indirect_ref_loc (input_location, se->expr); ! result = build_fold_indirect_ref_loc (input_location, ! se->expr); VEC_safe_push (tree, gc, retargs, se->expr); } else if (comp && comp->attr.dimension) --- 3353,3382 ---- se->expr = build_fold_indirect_ref_loc (input_location, se->expr); ! /* If the lhs of an assignment x = f(..) is allocatable and ! f2003 is allowed, we must do the automatic reallocation. ! TODO - deal with instrinsics, without using a temporary. */ ! if (gfc_option.flag_realloc_lhs ! && se->ss && se->ss->loop_chain ! && se->ss->loop_chain->is_alloc_lhs ! && !expr->value.function.isym ! && sym->result->as != NULL) ! { ! /* Evaluate the bounds of the result, if known. */ ! gfc_set_loop_bounds_from_array_spec (&mapping, se, ! sym->result->as); ! ! /* Perform the automatic reallocation. */ ! tmp = gfc_alloc_allocatable_for_assignment (se->loop, ! expr, NULL); ! gfc_add_expr_to_block (&se->pre, tmp); ! ! /* Pass the temporary as the first argument. */ ! result = info->descriptor; ! } ! else ! result = build_fold_indirect_ref_loc (input_location, ! se->expr); VEC_safe_push (tree, gc, retargs, se->expr); } else if (comp && comp->attr.dimension) *************** arrayfunc_assign_needs_temporary (gfc_ex *** 5220,5225 **** --- 5242,5254 ---- bool c = false; gfc_symbol *sym = expr1->symtree->n.sym; + /* Except for constant masks, the shape of an intrinsic function + result is unknown. TODO: make use of the masks to fix this. */ + if (gfc_option.flag_realloc_lhs + && expr1->symtree->n.sym->attr.allocatable + && expr2->value.function.isym != NULL) + return true; + /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) return true; *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 5339,5344 **** --- 5368,5374 ---- gfc_se se; gfc_ss *ss; gfc_component *comp = NULL; + gfc_loopinfo loop; if (arrayfunc_assign_needs_temporary (expr1, expr2)) return NULL; *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 5371,5376 **** --- 5401,5422 ---- se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); gcc_assert (se.ss != gfc_ss_terminator); + + /* Reallocate on assignment needs the loopinfo. This is + signalled to gfc_conv_procedure_call by setting the + is_alloc_lhs. */ + if (gfc_option.flag_realloc_lhs + && expr1->symtree->n.sym->attr.allocatable) + { + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + gfc_add_ss_to_loop (&loop, se.ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr1->where); + gfc_copy_loopinfo_to_se (&se, &loop); + ss->is_alloc_lhs = 1; + } + gfc_conv_function_expr (&se, expr2); gfc_add_block_to_block (&se.pre, &se.post); *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 5601,5606 **** --- 5647,5654 ---- /* Walk the lhs. */ lss = gfc_walk_expr (expr1); + if (expr1->symtree->n.sym->attr.allocatable) + lss->is_alloc_lhs = 1; rss = NULL; if (lss != gfc_ss_terminator) { *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 5746,5751 **** --- 5794,5808 ---- gfc_add_expr_to_block (&body, tmp); } + /* Allocate or reallocate lhs of allocatable array. */ + if (gfc_option.flag_realloc_lhs + && expr1->symtree->n.sym->attr.allocatable) + { + tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); + if (tmp != NULL_TREE) + gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); + } + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop, &body); Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 166125) --- gcc/fortran/trans-array.c (working copy) *************** gfc_trans_array_constructor (gfc_loopinf *** 1837,1842 **** --- 1837,1843 ---- tree offsetvar; tree desc; tree type; + tree tmp; bool dynamic; bool old_first_len, old_typespec_chararray_ctor; tree old_first_len_val; *************** gfc_trans_array_constructor (gfc_loopinf *** 1949,1954 **** --- 1950,1958 ---- } } + if (TREE_CODE (loop->to[0]) == VAR_DECL) + dynamic = true; + gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info, type, NULL_TREE, dynamic, true, false, where); *************** gfc_trans_array_constructor (gfc_loopinf *** 1963,1974 **** /* If the array grows dynamically, the upper bound of the loop variable is determined by the array's final upper bound. */ if (dynamic) ! loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); if (TREE_USED (offsetvar)) pushdecl (offsetvar); else gcc_assert (INTEGER_CST_P (offset)); #if 0 /* Disable bound checking for now because it's probably broken. */ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) --- 1967,1989 ---- /* If the array grows dynamically, the upper bound of the loop variable is determined by the array's final upper bound. */ if (dynamic) ! { ! tmp = fold_build2_loc (input_location, MINUS_EXPR, ! gfc_array_index_type, ! offsetvar, gfc_index_one_node); ! tmp = gfc_evaluate_now (tmp, &loop->pre); ! gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); ! if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL) ! gfc_add_modify (&loop->pre, loop->to[0], tmp); ! else ! loop->to[0] = tmp; ! } if (TREE_USED (offsetvar)) pushdecl (offsetvar); else gcc_assert (INTEGER_CST_P (offset)); + #if 0 /* Disable bound checking for now because it's probably broken. */ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) *************** gfc_conv_ss_descriptor (stmtblock_t * bl *** 2181,2186 **** --- 2196,2206 ---- tmp = gfc_conv_array_offset (se.expr); ss->data.info.offset = gfc_evaluate_now (tmp, block); + + /* Make absolutely sure that the saved_offset is indeed saved + so that the variable is still accessible after the loops + are translated. */ + ss->data.info.saved_offset = ss->data.info.offset; } } *************** gfc_conv_ss_startstride (gfc_loopinfo * *** 3209,3214 **** --- 3229,3238 ---- if (ss->type != GFC_SS_SECTION) continue; + /* Catch allocatable lhs in f2003. */ + if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs) + continue; + gfc_start_block (&inner); /* TODO: range checking for mapped dimensions. */ *************** gfc_conv_loop_setup (gfc_loopinfo * loop *** 3676,3681 **** --- 3700,3710 ---- continue; } + /* Avoid using an allocatable lhs in an assignment, since + there might be a reallocation coming. */ + if (loopspec[n] && ss->is_alloc_lhs) + continue; + if (ss->type != GFC_SS_SECTION) continue; *************** gfc_copy_only_alloc_comp (gfc_symbol * d *** 6457,6462 **** --- 6486,6863 ---- } + /* Returns the value of LBOUND for an expression. This could be broken out + from gfc_conv_intrinsic_bound but this seemed to be simpler. This is + called by gfc_alloc_allocatable_for_assignment. */ + static tree + get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) + { + tree lbound; + tree ubound; + tree stride; + tree cond, cond1, cond3, cond4; + tree tmp; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + tmp = gfc_rank_cst[dim]; + lbound = gfc_conv_descriptor_lbound_get (desc, tmp); + ubound = gfc_conv_descriptor_ubound_get (desc, tmp); + stride = gfc_conv_descriptor_stride_get (desc, tmp); + cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + ubound, lbound); + cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + stride, gfc_index_zero_node); + cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond3, cond1); + cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + stride, gfc_index_zero_node); + if (assumed_size) + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp, build_int_cst (gfc_array_index_type, + expr->rank - 1)); + else + cond = boolean_false_node; + + cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond3, cond4); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond, cond1); + + return fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + lbound, gfc_index_one_node); + } + else if (expr->expr_type == EXPR_VARIABLE) + { + tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); + return GFC_TYPE_ARRAY_LBOUND(tmp, dim); + } + else if (expr->expr_type == EXPR_FUNCTION) + { + /* A conversion function, so use the argument. */ + expr = expr->value.function.actual->expr; + if (expr->expr_type != EXPR_VARIABLE) + return gfc_index_one_node; + desc = TREE_TYPE (expr->symtree->n.sym->backend_decl); + return get_std_lbound (expr, desc, dim, assumed_size); + } + + return gfc_index_one_node; + } + + /* Allocate the lhs of an assignment to an allocatable array, otherwise + reallocate it. */ + + tree + gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, + gfc_expr *expr1, + gfc_expr *expr2) + { + stmtblock_t realloc_block; + stmtblock_t alloc_block; + stmtblock_t fblock; + gfc_ss *rss; + gfc_ss *lss; + tree realloc_expr; + tree alloc_expr; + tree size1; + tree size2; + tree array1; + tree cond; + tree tmp; + tree tmp2; + tree lbound; + tree ubound; + tree desc; + tree desc2; + tree offset; + tree jump_label1; + tree jump_label2; + tree neq_size; + tree lbd; + int n; + int dim; + gfc_array_spec * as; + + /* x = f(...) with x allocatable. In this case, expr1 is the rhs. + Find the lhs expression in the loop chain and set expr1 and + expr2 accordingly. */ + if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) + { + expr2 = expr1; + /* Find the ss for the lhs. */ + lss = loop->ss; + for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) + if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE) + break; + if (lss == gfc_ss_terminator) + return NULL_TREE; + expr1 = lss->expr; + } + + /* Bail out if this is not a valid allocate on assignment. */ + if (!expr1->symtree->n.sym->attr.allocatable + || (expr1->ref && expr1->ref->type == REF_ARRAY + && expr1->ref->u.ar.type != AR_FULL) + || (expr2 && !expr2->rank)) + return NULL_TREE; + + /* Find the ss for the lhs. */ + lss = loop->ss; + for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) + if (lss->expr == expr1) + break; + + if (lss == gfc_ss_terminator) + return NULL_TREE; + + /* Find an ss for the rhs. For operator expressions, we see the + ss's for the operands. Any one of these will do. */ + rss = loop->ss; + for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) + if (rss->expr != expr1 && rss != loop->temp_ss) + break; + + if (expr2 && rss == gfc_ss_terminator) + return NULL_TREE; + + gfc_start_block (&fblock); + + /* Since the lhs is allocatable, this must be a descriptor type. + Get the data and array size. */ + desc = lss->data.info.descriptor; + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + array1 = gfc_conv_descriptor_data_get (desc); + size1 = gfc_conv_descriptor_size (desc, expr1->rank); + + /* Get the rhs size. Fix both sizes. */ + if (expr2) + desc2 = rss->data.info.descriptor; + else + desc2 = NULL_TREE; + size2 = gfc_index_one_node; + for (n = 0; n < expr2->rank; n++) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + size2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, size2); + } + size1 = gfc_evaluate_now (size1, &fblock); + size2 = gfc_evaluate_now (size2, &fblock); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + size1, size2); + neq_size = gfc_evaluate_now (cond, &fblock); + + /* If the lhs is allocated and the lhs and rhs are equal length, jump + past the realloc/malloc. This allows F95 compliant expressions + to escape allocation on assignment. */ + jump_label1 = gfc_build_label_decl (NULL_TREE); + jump_label2 = gfc_build_label_decl (NULL_TREE); + + /* Allocate if data is NULL. */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + array1, build_int_cst (TREE_TYPE (array1), 0)); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + + /* Reallocate if sizes are different. */ + tmp = build3_v (COND_EXPR, neq_size, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + + if (expr2 && expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym + && expr2->value.function.isym->conversion) + { + /* For conversion functions, take the arg. */ + gfc_expr *arg = expr2->value.function.actual->expr; + as = gfc_get_full_arrayspec_from_expr (arg); + } + else if (expr2) + as = gfc_get_full_arrayspec_from_expr (expr2); + else + as = NULL; + + /* Reset the lhs bounds if any are different from the rhs. */ + if (as && expr2->expr_type == EXPR_VARIABLE) + { + for (n = 0; n < expr1->rank; n++) + { + dim = rss->data.info.dim[n]; + lbd = get_std_lbound (expr2, desc2, dim, + as->type == AS_ASSUMED_SIZE); + tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, lbd, tmp); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + } + } + + /* Otherwise jump past the (re)alloc code. */ + tmp = build1_v (GOTO_EXPR, jump_label2); + gfc_add_expr_to_block (&fblock, tmp); + + /* Add the label to start automatic (re)allocation. */ + tmp = build1_v (LABEL_EXPR, jump_label1); + gfc_add_expr_to_block (&fblock, tmp); + + /* Now modify the lhs descriptor and the associated scalarizer + variables. + 7.4.1.3: If variable is or becomes an unallocated allocatable + variable, then it is allocated with each deferred type parameter + equal to the corresponding type parameters of expr , with the + shape of expr , and with each lower bound equal to the + corresponding element of LBOUND(expr). */ + size1 = gfc_index_one_node; + offset = gfc_index_zero_node; + + for (n = 0; n < expr2->rank; n++) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + + lbound = gfc_index_one_node; + ubound = tmp; + + if (as) + { + lbd = get_std_lbound (expr2, desc2, n, + as->type == AS_ASSUMED_SIZE); + ubound = fold_build2_loc (input_location, + MINUS_EXPR, + gfc_array_index_type, + ubound, lbound); + ubound = fold_build2_loc (input_location, + PLUS_EXPR, + gfc_array_index_type, + ubound, lbd); + lbound = lbd; + } + + gfc_conv_descriptor_lbound_set (&fblock, desc, + gfc_rank_cst[n], + lbound); + gfc_conv_descriptor_ubound_set (&fblock, desc, + gfc_rank_cst[n], + ubound); + gfc_conv_descriptor_stride_set (&fblock, desc, + gfc_rank_cst[n], + size1); + lbound = gfc_conv_descriptor_lbound_get (desc, + gfc_rank_cst[n]); + tmp2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + lbound, size1); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp2); + size1 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, size1); + } + + /* Set the lhs descriptor and scalarizer offsets. For rank > 1, + the array offset is saved and the info.offset is used for a + running offset. Use the saved_offset instead. */ + tmp = gfc_conv_descriptor_offset (desc); + gfc_add_modify (&fblock, tmp, offset); + if (lss->data.info.saved_offset + && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL) + gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp); + + /* Now set the deltas for the lhs. */ + for (n = 0; n < expr1->rank; n++) + { + tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); + dim = lss->data.info.dim[n]; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, + loop->from[dim]); + if (lss->data.info.delta[dim] + && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL) + gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp); + } + + /* Get the new lhs size in bytes. */ + if (expr2->ts.type == BT_CHARACTER && expr2->ts.u.cl->backend_decl) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + tmp = fold_convert (gfc_array_index_type, tmp); + size2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, size2); + size2 = fold_convert (size_type_node, size2); + size2 = gfc_evaluate_now (size2, &fblock); + + /* Realloc expression. Note that the scalarizer uses desc.data + in the array reference - (*desc.data)[]. */ + gfc_init_block (&realloc_block); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_REALLOC], 2, + fold_convert (pvoid_type_node, array1), + size2); + gfc_conv_descriptor_data_set (&realloc_block, + desc, tmp); + realloc_expr = gfc_finish_block (&realloc_block); + + /* Only reallocate if sizes are different. */ + tmp = build3_v (COND_EXPR, neq_size, realloc_expr, + build_empty_stmt (input_location)); + realloc_expr = tmp; + + + /* Malloc expression. */ + gfc_init_block (&alloc_block); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MALLOC], 1, + size2); + gfc_conv_descriptor_data_set (&alloc_block, + desc, tmp); + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); + alloc_expr = gfc_finish_block (&alloc_block); + + /* Malloc if not allocated; realloc otherwise. */ + tmp = build_int_cst (TREE_TYPE (array1), 0); + cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, + array1, tmp); + tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); + gfc_add_expr_to_block (&fblock, tmp); + + /* Make sure that the scalarizer data pointer is updated. */ + if (lss->data.info.data + && TREE_CODE (lss->data.info.data) == VAR_DECL) + { + tmp = gfc_conv_descriptor_data_get (desc); + gfc_add_modify (&fblock, lss->data.info.data, tmp); + } + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, jump_label2); + gfc_add_expr_to_block (&fblock, tmp); + + return gfc_finish_block (&fblock); + } + + /* NULLIFY an allocatable/pointer array on function entry, free it on exit. Do likewise, recursively if necessary, with the allocatable components of derived types. */ Index: gcc/fortran/trans-array.h =================================================================== *** gcc/fortran/trans-array.h (revision 166125) --- gcc/fortran/trans-array.h (working copy) *************** tree gfc_copy_alloc_comp (gfc_symbol *, *** 57,62 **** --- 57,64 ---- tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); + tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*); + /* Add initialization for deferred arrays. */ void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); /* Generate an initializer for a static pointer or allocatable array. */ Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 166125) --- gcc/fortran/gfortran.h (working copy) *************** typedef struct *** 2237,2242 **** --- 2237,2243 ---- int flag_align_commons; int flag_whole_file; int flag_protect_parens; + int flag_realloc_lhs; int fpe; int rtcheck; Index: gcc/fortran/lang.opt =================================================================== *** gcc/fortran/lang.opt (revision 166125) --- gcc/fortran/lang.opt (working copy) *************** frange-check *** 478,483 **** --- 478,487 ---- Fortran Enable range checking during compilation + frealloc_lhs + Fortran + Reallocate the LHS in assignments + frecord-marker=4 Fortran RejectNegative Use a 4-byte record marker for unformatted files Index: gcc/fortran/invoke.texi =================================================================== *** gcc/fortran/invoke.texi (revision 166125) --- gcc/fortran/invoke.texi (working copy) *************** and warnings}. *** 171,177 **** -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -finit-integer=@var{n} -finit-real=@var{} @gol -finit-logical=@var{} -finit-character=@var{n} @gol ! -fno-align-commons -fno-protect-parens} @end table @menu --- 171,177 ---- -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -finit-integer=@var{n} -finit-real=@var{} @gol -finit-logical=@var{} -finit-character=@var{n} @gol ! -fno-align-commons -fno-protect-parens -frealloc_lhs} @end table @menu *************** levels such that the compiler does not d *** 1458,1463 **** --- 1458,1470 ---- @code{COMPLEX} expressions to produce faster code. Note that for the re-association optimization @option{-fno-signed-zeros} and @option{-fno-trapping-math} need to be in effect. + + @item -frealloc-lhs + @opindex @code{frealloc_lhs} + @cindex Reallocate the LHS in assignments + An allocatable left-hand side of an intrinsic assignment is automatically + (re)allocated if it is either unallocated or has a different shape. The + option is enabled by default except when @option{-std=f95} is given. @end table @xref{Code Gen Options,,Options for Code Generation Conventions, Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 166125) --- gcc/fortran/trans.h (working copy) *************** typedef struct gfc_ss *** 216,222 **** loops the terms appear in. This will be 1 for the RHS expressions, 2 for the LHS expressions, and 3(=1|2) for the temporary. The bit 'where' suppresses precalculation of scalars in WHERE assignments. */ ! unsigned useflags:2, where:1; } gfc_ss; #define gfc_get_ss() XCNEW (gfc_ss) --- 216,222 ---- loops the terms appear in. This will be 1 for the RHS expressions, 2 for the LHS expressions, and 3(=1|2) for the temporary. The bit 'where' suppresses precalculation of scalars in WHERE assignments. */ ! unsigned useflags:2, where:1, is_alloc_lhs:1; } gfc_ss; #define gfc_get_ss() XCNEW (gfc_ss) Index: gcc/fortran/options.c =================================================================== *** gcc/fortran/options.c (revision 166125) --- gcc/fortran/options.c (working copy) *************** gfc_init_options (unsigned int decoded_o *** 149,154 **** --- 149,155 ---- gfc_option.flag_init_character_value = (char)0; gfc_option.flag_align_commons = 1; gfc_option.flag_protect_parens = 1; + gfc_option.flag_realloc_lhs = -1; gfc_option.fpe = 0; gfc_option.rtcheck = 0; *************** gfc_post_options (const char **pfilename *** 266,271 **** --- 267,282 ---- if (flag_associative_math == -1) flag_associative_math = (!flag_trapping_math && !flag_signed_zeros); + /* By default, disable (re)allocation during assignment for -std=f95, + and enable it for F2003/F2008/GNU/Legacy. */ + if (gfc_option.flag_realloc_lhs == -1) + { + if (gfc_option.allow_std & GFC_STD_F2003) + gfc_option.flag_realloc_lhs = 1; + else + gfc_option.flag_realloc_lhs = 0; + } + /* -fbounds-check is equivalent to -fcheck=bounds */ if (flag_bounds_check) gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS; *************** gfc_handle_option (size_t scode, const c *** 964,969 **** --- 975,984 ---- gfc_option.flag_protect_parens = value; break; + case OPT_frealloc_lhs: + gfc_option.flag_realloc_lhs = value; + break; + case OPT_fcheck_: gfc_handle_runtime_check_option (arg); break; Index: gcc/testsuite/gfortran.dg/transpose_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/transpose_2.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/transpose_2.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" } program main implicit none --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" } program main implicit none Index: gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } program main integer, allocatable, dimension(:) :: vector --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } program main integer, allocatable, dimension(:) :: vector Index: gcc/testsuite/gfortran.dg/cshift_bounds_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/cshift_bounds_2.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/cshift_bounds_2.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" } program main integer, dimension(:,:), allocatable :: a, b --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" } program main integer, dimension(:,:), allocatable :: a, b Index: gcc/testsuite/gfortran.dg/matmul_bounds_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/matmul_bounds_3.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/matmul_bounds_3.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" } program main real, dimension(3,2) :: a --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" } program main real, dimension(3,2) :: a Index: gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03 =================================================================== *** gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03 (revision 0) --- gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03 (revision 0) *************** *** 0 **** --- 1,80 ---- + ! { dg-do run } + ! Tests the patch that implements F2003 automatic allocation and + ! reallocation of allocatable arrays on assignment. + ! + ! Contributed by Paul Thomas + ! + integer(4), allocatable :: a(:), b(:), c(:,:) + integer(4) :: j + integer(4) :: src(2:5) = [11,12,13,14] + integer(4) :: mat(2:3,5:6) + character(4), allocatable :: chr1(:) + character(4) :: chr2(2) = ["abcd", "wxyz"] + + allocate(a(1)) + mat = reshape (src, [2,2]) + + a = [4,3,2,1] + if (size(a, 1) .ne. 4) call abort + if (any (a .ne. [4,3,2,1])) call abort + + a = [((42 - i), i = 1, 10)] + if (size(a, 1) .ne. 10) call abort + if (any (a .ne. [((42 - i), i = 1, 10)])) call abort + + b = a + if (size(b, 1) .ne. 10) call abort + if (any (b .ne. a)) call abort + + a = [4,3,2,1] + if (size(a, 1) .ne. 4) call abort + if (any (a .ne. [4,3,2,1])) call abort + + a = b + if (size(a, 1) .ne. 10) call abort + if (any (a .ne. [((42 - i), i = 1, 10)])) call abort + + j = 20 + a = [(i, i = 1, j)] + if (size(a, 1) .ne. j) call abort + if (any (a .ne. [(i, i = 1, j)])) call abort + + a = foo (15) + if (size(a, 1) .ne. 15) call abort + if (any (a .ne. [((i + 15), i = 1, 15)])) call abort + + a = src + if (lbound(a, 1) .ne. lbound(src, 1)) call abort + if (ubound(a, 1) .ne. ubound(src, 1)) call abort + if (any (a .ne. [11,12,13,14])) call abort + + k = 7 + a = b(k:8) + if (lbound(a, 1) .ne. lbound (b(k:8), 1)) call abort + if (ubound(a, 1) .ne. ubound (b(k:8), 1)) call abort + if (any (a .ne. [35,34])) call abort + + c = mat + if (any (lbound (c) .ne. lbound (mat))) call abort + if (any (ubound (c) .ne. ubound (mat))) call abort + if (any (c .ne. mat)) call abort + + deallocate (c) + c = mat(2:,:) + if (any (lbound (c) .ne. lbound (mat(2:,:)))) call abort + + chr1 = chr2(2:1:-1) + if (lbound(chr1, 1) .ne. 1) call abort + if (any (chr1 .ne. chr2(2:1:-1))) call abort + + b = c(1, :) + c(2, :) + if (lbound(b, 1) .ne. lbound (c(1, :) + c(2, :), 1)) call abort + if (any (b .ne. c(1, :) + c(2, :))) call abort + contains + function foo (n) result(res) + integer(4), allocatable, dimension(:) :: res + integer(4) :: n + allocate (res(n)) + res = [((i + 15), i = 1, n)] + end function foo + end Index: gcc/testsuite/gfortran.dg/matmul_bounds_5.f90 =================================================================== *** gcc/testsuite/gfortran.dg/matmul_bounds_5.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/matmul_bounds_5.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } program main real, dimension(2,3) :: a --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } program main real, dimension(2,3) :: a Index: gcc/testsuite/gfortran.dg/matmul_bounds_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/matmul_bounds_2.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/matmul_bounds_2.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" } program main real, dimension(3,2) :: a --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" } program main real, dimension(3,2) :: a Index: gcc/testsuite/gfortran.dg/matmul_bounds_4.f90 =================================================================== *** gcc/testsuite/gfortran.dg/matmul_bounds_4.f90 (revision 166125) --- gcc/testsuite/gfortran.dg/matmul_bounds_4.f90 (working copy) *************** *** 1,5 **** ! { dg-do run } ! ! { dg-options "-fbounds-check" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } program main real, dimension(3) :: a --- 1,5 ---- ! { dg-do run } ! ! { dg-options "-fbounds-check -fno-realloc_lhs" } ! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } program main real, dimension(3) :: a Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 =================================================================== *** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (revision 0) --- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (revision 0) *************** *** 0 **** --- 1,84 ---- + ! { dg-do run } + ! Tests the patch that implements F2003 automatic allocation and + ! reallocation of allocatable arrays on assignment. The tests + ! below were generated in the final stages of the development of + ! this patch. + ! + ! Contributed by Dominique Dhumieres + ! and Tobias Burnus + ! + call test1 + call test2 + call test3 + call test4 + contains + subroutine test1 + ! + ! Check that the bounds are set correctly, when assigning + ! to an array that already has the correct shape. + ! + real :: a(10) = 1, b(51:60) = 2 + real, allocatable :: c(:), d(:) + c=a + if (lbound (c, 1) .ne. lbound(a, 1)) call abort + if (ubound (c, 1) .ne. ubound(a, 1)) call abort + c=b + if (lbound (c, 1) .ne. lbound(b, 1)) call abort + if (ubound (c, 1) .ne. ubound(b, 1)) call abort + d=b + if (lbound (d, 1) .ne. lbound(b, 1)) call abort + if (ubound (d, 1) .ne. ubound(b, 1)) call abort + d=a + if (lbound (d, 1) .ne. lbound(a, 1)) call abort + if (ubound (d, 1) .ne. ubound(a, 1)) call abort + end subroutine + subroutine test2 + ! + ! Check that the bounds are set correctly, when making an + ! assignment with an implicit conversion. First with a + ! non-descriptor variable.... + ! + integer(4), allocatable :: a(:) + integer(8) :: b(5:6) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) call abort + if (ubound (a, 1) .ne. ubound(b, 1)) call abort + end subroutine + subroutine test3 + ! + ! ...and now a descriptor variable. + ! + integer(4), allocatable :: a(:) + integer(8), allocatable :: b(:) + allocate (b(7:11)) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) call abort + if (ubound (a, 1) .ne. ubound(b, 1)) call abort + end subroutine + subroutine test4 + ! + ! Check assignments of the kind a = f(...) + ! + integer, allocatable :: a(:) + integer, allocatable :: c(:) + a = f() + if (any (a .ne. [1, 2, 3, 4])) call abort + c = a + 8 + a = f (c) + if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort + deallocate (c) + a = f (c) + if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort + end subroutine + function f(b) + integer, allocatable, optional :: b(:) + integer :: f(4) + if (.not.present (b)) then + f = [1,2,3,4] + elseif (.not.allocated (b)) then + f = [5,6,7,8] + else + f = b + end if + end function f + end