[PATCH] Fix for PR fortran/21375
Steve Kargl
sgk@troutmask.apl.washington.edu
Sun Jun 5 17:31:00 GMT 2005
On Sat, Jun 04, 2005 at 03:45:10PM -0700, Steve Kargl wrote:
> On Sun, Jun 05, 2005 at 12:29:56AM +0200, Tobias Schl?ter wrote:
>>Steve Kargl wrote:
>>> You're right about the DEALLOCATE(a1,a2,stat=i) case above. Unfortunately,
>>> I don't know how to fix this. I assume that inside the for loop of
>>> gfc_trans_deallocate(), I need to check if pstat is set to 1 on each
>>> iteration and if so set a have_seen_problem flag. Once the for loop
>>> exits, then check have_seen_problem and reset pstat with an appropriate
>>> value. Any help would be appreciate (in that I don't understand the
>>> trans-*) file too well.
>>
>> Since the stat variable is defined to be zero for success, and non-zero
>> otherwise, I think we could just set the user-supplied variable to
>> zero before we call deallocate, and then simply add the result to the
>> user variable instead of assigning it, effectively making the stat
>> variable count the unsuccessfull deallocations.
>>
>
> Yes, I think your suggestion would work. Unfortunately, I don't
> know how to implement this. :(
See attached patch (for a fun exercise in hacking).
Bootstrapped and regression tested on i386-*-freebsd.
ChangeLog entries for patch and test case are the
same as in the first email of the thread.
--
Steve
-------------- next part --------------
Index: trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.47
diff -c -p -r1.47 trans-array.c
*** trans-array.c 31 May 2005 17:19:10 -0000 1.47
--- trans-array.c 5 Jun 2005 17:11:14 -0000
*************** gfc_array_allocate (gfc_se * se, gfc_ref
*** 2767,2773 ****
/*GCC ARRAYS*/
tree
! gfc_array_deallocate (tree descriptor)
{
tree var;
tree tmp;
--- 2767,2773 ----
/*GCC ARRAYS*/
tree
! gfc_array_deallocate (tree descriptor, tree pstat)
{
tree var;
tree tmp;
*************** gfc_array_deallocate (tree descriptor)
*** 2782,2788 ****
/* Parameter is the address of the data component. */
tmp = gfc_chainon_list (NULL_TREE, var);
! tmp = gfc_chainon_list (tmp, integer_zero_node);
tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
--- 2782,2788 ----
/* Parameter is the address of the data component. */
tmp = gfc_chainon_list (NULL_TREE, var);
! tmp = gfc_chainon_list (tmp, pstat);
tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4012,4021 ****
/* Allocatable arrays need to be freed when they go out of scope. */
if (sym->attr.allocatable)
{
gfc_start_block (&block);
/* Deallocate if still allocated at the end of the procedure. */
! deallocate = gfc_array_deallocate (descriptor);
tmp = gfc_conv_descriptor_data (descriptor);
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
--- 4012,4024 ----
/* Allocatable arrays need to be freed when they go out of scope. */
if (sym->attr.allocatable)
{
+ tree pstat;
+
gfc_start_block (&block);
/* Deallocate if still allocated at the end of the procedure. */
! pstat = integer_zero_node;
! deallocate = gfc_array_deallocate (descriptor, pstat);
tmp = gfc_conv_descriptor_data (descriptor);
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
Index: trans-array.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.h,v
retrieving revision 1.8
diff -c -p -r1.8 trans-array.h
*** trans-array.h 12 Mar 2005 21:44:32 -0000 1.8
--- trans-array.h 5 Jun 2005 17:11:14 -0000
*************** Software Foundation, 59 Temple Place - S
*** 20,26 ****
02111-1307, USA. */
/* Generate code to free an array. */
! tree gfc_array_deallocate (tree);
/* Generate code to initialize an allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
--- 20,26 ----
02111-1307, USA. */
/* Generate code to free an array. */
! tree gfc_array_deallocate (tree, tree);
/* Generate code to initialize an allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
Index: trans-decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.60
diff -c -p -r1.60 trans-decl.c
*** trans-decl.c 1 Jun 2005 02:51:12 -0000 1.60
--- trans-decl.c 5 Jun 2005 17:11:15 -0000
*************** gfc_build_builtin_function_decls (void)
*** 1899,1905 ****
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
! void_type_node, 1, ppvoid_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
--- 1899,1906 ----
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
! void_type_node, 2, ppvoid_type_node,
! gfc_int4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
Index: trans-stmt.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-stmt.c,v
retrieving revision 1.32
diff -c -p -r1.32 trans-stmt.c
*** trans-stmt.c 26 May 2005 18:36:10 -0000 1.32
--- trans-stmt.c 5 Jun 2005 17:11:17 -0000
*************** gfc_trans_allocate (gfc_code * code)
*** 3291,3306 ****
tree
gfc_trans_deallocate (gfc_code * code)
{
gfc_se se;
gfc_alloc *al;
gfc_expr *expr;
tree var;
! tree tmp;
tree type;
stmtblock_t block;
gfc_start_block (&block);
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->expr;
--- 3291,3326 ----
tree
gfc_trans_deallocate (gfc_code * code)
{
+ int seen = 0;
gfc_se se;
gfc_alloc *al;
gfc_expr *expr;
tree var;
! tree tmp, parm;
tree type;
+ tree stat, pstat, astat, apstat;
stmtblock_t block;
gfc_start_block (&block);
+ /* Set up the optional STAT= */
+ if (code->expr)
+ {
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+ stat = gfc_create_var (gfc_int4_type_node, "stat");
+ pstat = gfc_build_addr_expr (NULL, stat);
+ astat = gfc_create_var (gfc_int4_type_node, "astat");
+ apstat = gfc_build_addr_expr (NULL, astat);
+ apstat = build_int_cst (gfc_int4_type_node, 0);
+ }
+ else
+ {
+ pstat = integer_zero_node;
+ stat = NULL_TREE;
+ apstat = integer_zero_node;
+ astat = NULL_TREE;
+ }
+
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->expr;
*************** gfc_trans_deallocate (gfc_code * code)
*** 3314,3323 ****
gfc_conv_expr (&se, expr);
if (expr->symtree->n.sym->attr.dimension)
! {
! tmp = gfc_array_deallocate (se.expr);
! gfc_add_expr_to_block (&se.pre, tmp);
! }
else
{
type = build_pointer_type (TREE_TYPE (se.expr));
--- 3334,3340 ----
gfc_conv_expr (&se, expr);
if (expr->symtree->n.sym->attr.dimension)
! tmp = gfc_array_deallocate (se.expr, pstat);
else
{
type = build_pointer_type (TREE_TYPE (se.expr));
*************** gfc_trans_deallocate (gfc_code * code)
*** 3325,3337 ****
tmp = gfc_build_addr_expr (type, se.expr);
gfc_add_modify_expr (&se.pre, var, tmp);
! tmp = gfc_chainon_list (NULL_TREE, var);
! tmp = gfc_chainon_list (tmp, integer_zero_node);
! tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
! gfc_add_expr_to_block (&se.pre, tmp);
}
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
--- 3342,3381 ----
tmp = gfc_build_addr_expr (type, se.expr);
gfc_add_modify_expr (&se.pre, var, tmp);
! parm = gfc_chainon_list (NULL_TREE, var);
! parm = gfc_chainon_list (parm, pstat);
! tmp = gfc_build_function_call (gfor_fndecl_deallocate, parm);
}
+
+
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ /* Keep track of the number of failed deallocations. */
+ if (code->expr)
+ {
+ if (seen == 0)
+ {
+ apstat = fold_convert (TREE_TYPE (stat), stat);
+ seen = 1;
+ }
+ else
+ apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
+
+ gfc_add_modify_expr (&se.pre, astat, apstat);
+ }
+
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
+
+ }
+
+ /* Assign the value to the status variable. */
+ if (code->expr)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr);
+ tmp = convert (TREE_TYPE (se.expr), astat);
+ gfc_add_modify_expr (&block, se.expr, tmp);
}
return gfc_finish_block (&block);
-------------- next part --------------
! { dg-do run }
! PR 21375
! Test that the STAT argument to DEALLOCATE works with POINTERS and
! ALLOCATABLE arrays.
program deallocate_stat
implicit none
integer i
real, pointer :: a1(:), a2(:,:), a3(:,:,:), a4(:,:,:,:), &
& a5(:,:,:,:,:), a6(:,:,:,:,:,:), a7(:,:,:,:,:,:,:)
real, allocatable :: b1(:), b2(:,:), b3(:,:,:), b4(:,:,:,:), &
& b5(:,:,:,:,:), b6(:,:,:,:,:,:), b7(:,:,:,:,:,:,:)
allocate(a1(2), a2(2,2), a3(2,2,2), a4(2,2,2,2), a5(2,2,2,2,2))
allocate(a6(2,2,2,2,2,2), a7(2,2,2,2,2,2,2))
a1 = 1. ; a2 = 2. ; a3 = 3. ; a4 = 4. ; a5 = 5. ; a6 = 6. ; a7 = 7.
i = 13
deallocate(a1, stat=i) ; if (i /= 0) call abort
deallocate(a2, stat=i) ; if (i /= 0) call abort
deallocate(a3, stat=i) ; if (i /= 0) call abort
deallocate(a4, stat=i) ; if (i /= 0) call abort
deallocate(a5, stat=i) ; if (i /= 0) call abort
deallocate(a6, stat=i) ; if (i /= 0) call abort
deallocate(a7, stat=i) ; if (i /= 0) call abort
i = 14
deallocate(a1, stat=i) ; if (i /= 1) call abort
deallocate(a2, stat=i) ; if (i /= 1) call abort
deallocate(a3, stat=i) ; if (i /= 1) call abort
deallocate(a4, stat=i) ; if (i /= 1) call abort
deallocate(a5, stat=i) ; if (i /= 1) call abort
deallocate(a6, stat=i) ; if (i /= 1) call abort
deallocate(a7, stat=i) ; if (i /= 1) call abort
allocate(b1(2), b2(2,2), b3(2,2,2), b4(2,2,2,2), b5(2,2,2,2,2))
allocate(b6(2,2,2,2,2,2), b7(2,2,2,2,2,2,2))
b1 = 1. ; b2 = 2. ; b3 = 3. ; b4 = 4. ; b5 = 5. ; b6 = 6. ; b7 = 7.
i = 13
deallocate(b1, stat=i) ; if (i /= 0) call abort
deallocate(b2, stat=i) ; if (i /= 0) call abort
deallocate(b3, stat=i) ; if (i /= 0) call abort
deallocate(b4, stat=i) ; if (i /= 0) call abort
deallocate(b5, stat=i) ; if (i /= 0) call abort
deallocate(b6, stat=i) ; if (i /= 0) call abort
deallocate(b7, stat=i) ; if (i /= 0) call abort
i = 14
deallocate(b1, stat=i) ; if (i /= 1) call abort
deallocate(b2, stat=i) ; if (i /= 1) call abort
deallocate(b3, stat=i) ; if (i /= 1) call abort
deallocate(b4, stat=i) ; if (i /= 1) call abort
deallocate(b5, stat=i) ; if (i /= 1) call abort
deallocate(b6, stat=i) ; if (i /= 1) call abort
deallocate(b7, stat=i) ; if (i /= 1) call abort
allocate(a1(2), a2(2,2), a3(2,2,2), b4(2,2,2,2), b5(2,2,2,2,2))
allocate(b6(2,2,2,2,2,2))
a1 = 1. ; a2 = 2. ; a3 = 3. ; b4 = 4. ; b5 = 5. ; b6 = 6.
i = 13
deallocate(a1, stat=i) ; if (i /= 0) call abort
deallocate(a2, a1, stat=i) ; if (i /= 1) call abort
deallocate(a1, a3, a2, stat=i) ; if (i /= 2) call abort
deallocate(b4, stat=i) ; if (i /= 0) call abort
deallocate(b4, b5, stat=i) ; if (i /= 1) call abort
deallocate(b4, b5, b6, stat=i) ; if (i /= 2) call abort
end program deallocate_stat
More information about the Fortran
mailing list