[PATCH] Fix for PR fortran/21375
Steve Kargl
sgk@troutmask.apl.washington.edu
Sat Jun 4 17:35:00 GMT 2005
The first diff was posted here
http://gcc.gnu.org/ml/fortran/2005-05/msg00064.html
I attached a new diff and a testcase. This patch
fixes PR fortran/21375. The problem is that gfortran
does not properly handle the STAT= feature for deallocate.
Bootstrapped and regtested on i386-*-freebsd for mainline?
Ok for mainline? Ok for 4.0 after regression testing?
2005-06-04 Steven G. Kargl <kargls@comcast.net>
PR fortran/21375
* trans-array.c (gfc_array_deallocate): pstat is new argument
(gfc_array_allocate): update gfc_array_deallocate() call.
(gfc_trans_deferred_array): ditto.
* trans-array.h: update gfc_array_deallocate() prototype.
* trans-decl.c (gfc_build_builtin_function_decls): update declaration
* trans-stmt.c (gfc_trans_deallocate): Implement STAT= feature.
2005-06-04 Steven G. Kargl <kargls@comcast.net>
PR fortran/21375
* gfortran.dg/pr21375.f90: New test.
--
Steve
-------------- 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
end program deallocate_stat
-------------- next part --------------
? pr21375.diff
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 4 Jun 2005 16:39:50 -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 4 Jun 2005 16:39:50 -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 4 Jun 2005 16:39:52 -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 4 Jun 2005 16:39:54 -0000
*************** gfc_trans_deallocate (gfc_code * code)
*** 3295,3306 ****
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;
--- 3295,3324 ----
gfc_alloc *al;
gfc_expr *expr;
tree var;
! tree tmp, parm;
tree type;
+ tree stat, pstat, error_label;
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);
+
+ error_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (error_label) = 1;
+ }
+ else
+ {
+ pstat = integer_zero_node;
+ stat = error_label = NULL_TREE;
+ }
+
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->expr;
*************** gfc_trans_deallocate (gfc_code * code)
*** 3315,3321 ****
if (expr->symtree->n.sym->attr.dimension)
{
! tmp = gfc_array_deallocate (se.expr);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
--- 3333,3339 ----
if (expr->symtree->n.sym->attr.dimension)
{
! tmp = gfc_array_deallocate (se.expr, pstat);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
*************** gfc_trans_deallocate (gfc_code * code)
*** 3325,3339 ****
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);
}
--- 3343,3370 ----
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);
+
}
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Assign the value to the status variable. */
+ if (code->expr)
+ {
+ tmp = build1_v (LABEL_EXPR, error_label);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr);
+ tmp = convert (TREE_TYPE (se.expr), stat);
+ gfc_add_modify_expr (&block, se.expr, tmp);
+ }
+
return gfc_finish_block (&block);
}
More information about the Fortran
mailing list