diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 27 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 59 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 113 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 9 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/multiple_allocation_3.f90 | 19 |
9 files changed, 166 insertions, 109 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9537bbf..a2614a0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2011-07-27 Daniel Carrera <dcarrera@gmail.com> + + PR fortran/49755 + * trans.c (gfc_allocate_using_malloc): Change function signature. + Return nothing. New parameter "pointer". Eliminate temorary variables. + (gfc_allocate_using_lib): Ditto. + (gfc_allocate_allocatable): Ditto. Update call to gfc_allocate_using_lib + and gfc_allocate_using_malloc. Do not free and then reallocate a + variable that is already allocated. + (gfc_likely): New function. Basedon gfc_unlikely. + * trans-array.c (gfc_array_init_size): New parameter "descriptor_block". + Instructions to modify the array descriptor are stored in this block + while other instructions continue to be stored in "pblock". + (gfc_array_allocate): Update call to gfc_array_init_size. Move the + descriptor_block so that the array descriptor is only updated if + the array was allocated successfully. + Update calls to gfc_allocate_allocatable and gfc_allocate_using_malloc. + * trans.h (gfc_allocate_allocatable): Change function signature. + Function now returns void. + (gfc_allocate_using_lib): Ditto, and new function parameter. + (gfc_allocate_using_malloc): Ditto. + * trans-openmp.c (gfc_omp_clause_default_ctor, + gfc_omp_clause_copy_ctor,gfc_trans_omp_array_reduction): Replace a call + to gfc_allocate_allocatable with gfc_allocate_using_malloc. + * trans-stmt.c (gfc_trans_allocate): Update function calls for + gfc_allocate_allocatable and gfc_allocate_using_malloc. + 2011-07-26 Tobias Burnus <burnus@net-b.de> * trans-array.c (CAF_TOKEN_FIELD): New macro constant. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ff059a3..dc8fdb8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4164,7 +4164,7 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) size = 1 - lbound; a.ubound[n] = specified_upper_bound; a.stride[n] = stride; - size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound + size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); stride = stride * size; } @@ -4182,8 +4182,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, - gfc_expr ** lower, gfc_expr ** upper, - stmtblock_t * pblock, tree * overflow) + gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, + stmtblock_t * descriptor_block, tree * overflow) { tree type; tree tmp; @@ -4209,7 +4209,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); or_expr = boolean_false_node; @@ -4242,8 +4242,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ubound = lower[n]; } } - gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], - se.expr); + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); conv_lbound = se.expr; /* Work out the offset for this component. */ @@ -4258,12 +4258,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; /* Store the stride. */ - gfc_conv_descriptor_stride_set (pblock, descriptor, + gfc_conv_descriptor_stride_set (descriptor_block, descriptor, gfc_rank_cst[n], stride); /* Calculate size and check whether extent is negative. */ @@ -4323,8 +4323,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ubound = lower[n]; } } - gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], - se.expr); + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); if (n < rank + corank - 1) { @@ -4332,7 +4332,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gcc_assert (ubound); gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); } } @@ -4415,6 +4415,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree overflow; /* Boolean storing whether size calculation overflows. */ tree var_overflow = NULL_TREE; tree cond; + tree set_descriptor; + stmtblock_t set_descriptor_block; stmtblock_t elseblock; gfc_expr **lower; gfc_expr **upper; @@ -4481,9 +4483,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, } overflow = integer_zero_node; + + gfc_init_block (&set_descriptor_block); size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, - &se->pre, &overflow); + &se->pre, &set_descriptor_block, &overflow); + if (dimension) { @@ -4511,22 +4516,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, } gfc_start_block (&elseblock); - + /* Allocate memory to store the data. */ pointer = gfc_conv_descriptor_data_get (se->expr); STRIP_NOPS (pointer); /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) - tmp = gfc_allocate_allocatable (&elseblock, pointer, size, - status, errmsg, errlen, expr); + gfc_allocate_allocatable (&elseblock, pointer, size, + status, errmsg, errlen, expr); else - tmp = gfc_allocate_using_malloc (&elseblock, size, status); - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - pointer, tmp); - - gfc_add_expr_to_block (&elseblock, tmp); + gfc_allocate_using_malloc (&elseblock, pointer, size, status); if (dimension) { @@ -4540,8 +4540,23 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_add_expr_to_block (&se->pre, tmp); + /* Update the array descriptors. */ if (dimension) - gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); + gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (status != NULL_TREE) + { + cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); + gfc_add_expr_to_block (&se->pre, + fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_likely (cond), set_descriptor, + build_empty_stmt (input_location))); + } + else + gfc_add_expr_to_block (&se->pre, set_descriptor); if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && expr->ts.u.derived->attr.alloc_comp) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index cd5ef0a..29e342f 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -188,10 +188,11 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - ptr = gfc_allocate_allocatable (&cond_block, - build_int_cst (pvoid_type_node, 0), - size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); gfc_conv_descriptor_data_set (&cond_block, decl, ptr); + then_b = gfc_finish_block (&cond_block); gfc_init_block (&cond_block); @@ -241,10 +242,11 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - ptr = gfc_allocate_allocatable (&block, - build_int_cst (pvoid_type_node, 0), - size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); gfc_conv_descriptor_data_set (&block, dest, ptr); + call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, ptr, fold_convert (pvoid_type_node, @@ -663,10 +665,11 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - ptr = gfc_allocate_allocatable (&block, - build_int_cst (pvoid_type_node, 0), - size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); gfc_conv_descriptor_data_set (&block, decl, ptr); + gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false, false)); stmt = gfc_finish_block (&block); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 75d72a2..defa445 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4867,15 +4867,10 @@ gfc_trans_allocate (gfc_code * code) /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) - tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz, - stat, errmsg, errlen, expr); + gfc_allocate_allocatable (&se.pre, se.expr, memsz, + stat, errmsg, errlen, expr); else - tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat); - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), tmp)); - gfc_add_expr_to_block (&se.pre, tmp); + gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { @@ -4901,7 +4896,7 @@ gfc_trans_allocate (gfc_code * code) boolean_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - parm, tmp, + gfc_unlikely(parm), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 83fabe2..2f8c7fd 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -582,11 +582,11 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) } return newmem; } */ -tree -gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status) +void +gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, + tree size, tree status) { - stmtblock_t alloc_block; - tree res, tmp, on_error; + tree tmp, on_error, error_cond; tree status_type = status ? TREE_TYPE (status) : NULL_TREE; /* Evaluate size only once, and make sure it has the right type. */ @@ -594,19 +594,15 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status) if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); - /* Create a variable to hold the result. */ - res = gfc_create_var (prvoid_type_node, NULL); - - /* Set the optional status variable to zero. */ + /* If successful and stat= is given, set status to 0. */ if (status != NULL_TREE) gfc_add_expr_to_block (block, fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, build_int_cst (status_type, 0))); /* The allocation itself. */ - gfc_start_block (&alloc_block); - gfc_add_modify (&alloc_block, res, - fold_convert (prvoid_type_node, + gfc_add_modify (block, pointer, + fold_convert (TREE_TYPE (pointer), build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MALLOC], 1, fold_build2_loc (input_location, @@ -623,16 +619,14 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status) gfc_build_localized_cstring_const ("Allocation would exceed memory limit"))); + error_cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, pointer, + build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, res, - build_int_cst (prvoid_type_node, 0)), - on_error, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&alloc_block, tmp); - gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block)); + gfc_unlikely(error_cond), on_error, + build_empty_stmt (input_location)); - return res; + gfc_add_expr_to_block (block, tmp); } @@ -648,20 +642,17 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status) newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL); return newmem; } */ -tree -gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status, - tree errmsg, tree errlen) +void +gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, + tree status, tree errmsg, tree errlen) { - tree res, pstat; + tree tmp, pstat; /* Evaluate size only once, and make sure it has the right type. */ size = gfc_evaluate_now (size, block); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); - /* Create a variable to hold the result. */ - res = gfc_create_var (prvoid_type_node, NULL); - /* The allocation itself. */ if (status == NULL_TREE) pstat = null_pointer_node; @@ -675,19 +666,20 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status, errlen = build_int_cst (integer_type_node, 0); } - gfc_add_modify (block, res, - fold_convert (prvoid_type_node, - build_call_expr_loc (input_location, - gfor_fndecl_caf_register, 6, - fold_build2_loc (input_location, + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_register, 6, + fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)), - build_int_cst (integer_type_node, + build_int_cst (integer_type_node, GFC_CAF_COARRAY_ALLOC), - null_pointer_node, /* token */ - pstat, errmsg, errlen))); + null_pointer_node, /* token */ + pstat, errmsg, errlen); - return res; + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (pointer), pointer, + fold_convert ( TREE_TYPE (pointer), tmp)); + gfc_add_expr_to_block (block, tmp); } @@ -705,12 +697,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status, else { if (stat) - { - free (mem); - mem = allocate (size, stat); stat = LIBERROR_ALLOCATION; - return mem; - } else runtime_error ("Attempting to allocate already allocated variable"); } @@ -718,19 +705,17 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status, expr must be set to the original expression being allocated for its locus and variable name in case a runtime error has to be printed. */ -tree +void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status, tree errmsg, tree errlen, gfc_expr* expr) { stmtblock_t alloc_block; - tree res, tmp, null_mem, alloc, error; + tree tmp, null_mem, alloc, error; tree type = TREE_TYPE (mem); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) size = fold_convert (size_type_node, size); - /* Create a variable to hold the result. */ - res = gfc_create_var (type, NULL); null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node, mem, build_int_cst (type, 0))); @@ -741,12 +726,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status, if (gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_expr_attr (expr).codimension) - tmp = gfc_allocate_using_lib (&alloc_block, size, status, - errmsg, errlen); + gfc_allocate_using_lib (&alloc_block, mem, size, status, + errmsg, errlen); else - tmp = gfc_allocate_using_malloc (&alloc_block, size, status); + gfc_allocate_using_malloc (&alloc_block, mem, size, status); - gfc_add_modify (&alloc_block, res, fold_convert (type, tmp)); alloc = gfc_finish_block (&alloc_block); /* If mem is not NULL, we issue a runtime error or set the @@ -772,27 +756,14 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status, if (status != NULL_TREE) { tree status_type = TREE_TYPE (status); - stmtblock_t set_status_block; - - gfc_start_block (&set_status_block); - tmp = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_FREE], 1, - fold_convert (pvoid_type_node, mem)); - gfc_add_expr_to_block (&set_status_block, tmp); - - tmp = gfc_allocate_using_malloc (&set_status_block, size, status); - gfc_add_modify (&set_status_block, res, fold_convert (type, tmp)); - gfc_add_modify (&set_status_block, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); - error = gfc_finish_block (&set_status_block); + error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, LIBERROR_ALLOCATION)); } tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, error, alloc); gfc_add_expr_to_block (block, tmp); - - return res; } @@ -1619,3 +1590,19 @@ gfc_unlikely (tree cond) cond = fold_convert (boolean_type_node, cond); return cond; } + + +/* Helper function for marking a boolean expression tree as likely. */ + +tree +gfc_likely (tree cond) +{ + tree tmp; + + cond = fold_convert (long_integer_type_node, cond); + tmp = build_one_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); + cond = fold_convert (boolean_type_node, cond); + return cond; +} diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 73e2fa0..a53360f 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -517,7 +517,8 @@ void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *); -/* Mark a condition as unlikely. */ +/* Mark a condition as likely or unlikely. */ +tree gfc_likely (tree); tree gfc_unlikely (tree); /* Generate a runtime error call. */ @@ -541,12 +542,12 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree); tree gfc_build_memcpy_call (tree, tree, tree); /* Allocate memory for allocatable variables, with optional status variable. */ -tree gfc_allocate_allocatable (stmtblock_t*, tree, tree, +void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, tree, gfc_expr*); /* Allocate memory, with optional status variable. */ -tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree); -tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree); +void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); +void gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree, tree); /* Generate code to deallocate an array. */ tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f0cb44b..a1df3d1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2011-07-27 Daniel Carrera <dcarrera@gmail.com> + + PR fortran/49755 + * gfortran.dg/multiple_allocation_1.f90: Fix test. Allocating an + allocated array should *not* change its size. + * gfortran.dg/multiple_allocation_3.f90: New test. + 2011-07-26 Paolo Carlini <paolo.carlini@oracle.com> PR c++/49776 diff --git a/gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 b/gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 index 2b91373..58888f0 100644 --- a/gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 +++ b/gcc/testsuite/gfortran.dg/multiple_allocation_1.f90 @@ -1,6 +1,8 @@ ! { dg-do run } ! PR 25031 - We didn't cause an error when allocating an already ! allocated array. +! +! This testcase has been modified to fix PR 49755. program alloc_test implicit none integer :: i @@ -8,11 +10,12 @@ program alloc_test integer, pointer :: b(:) allocate(a(4)) - ! This should set the stat code and change the size. + ! This should set the stat code but not change the size. allocate(a(3),stat=i) if (i == 0) call abort if (.not. allocated(a)) call abort - if (size(a) /= 3) call abort + if (size(a) /= 4) call abort + ! It's OK to allocate pointers twice (even though this causes ! a memory leak) allocate(b(4)) diff --git a/gcc/testsuite/gfortran.dg/multiple_allocation_3.f90 b/gcc/testsuite/gfortran.dg/multiple_allocation_3.f90 new file mode 100644 index 0000000..482b388 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/multiple_allocation_3.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 49755 - If allocating an already allocated array, and stat= +! is given, set stat to non zero and do not touch the array. +program test + integer, allocatable :: A(:, :) + integer :: stat + + allocate(A(20,20)) + A = 42 + + ! Allocate of already allocated variable + allocate (A(5,5), stat=stat) + + ! Expected: Error stat and previous allocation status + if (stat == 0) call abort () + if (any (shape (A) /= [20, 20])) call abort () + if (any (A /= 42)) call abort () +end program + |