[PATCH/gfortran] Partial fix for PR 21375
Steve Kargl
sgk@troutmask.apl.washington.edu
Mon May 9 03:44:00 GMT 2005
The attached patch fixes the use of STAT= in
a deallocate statement for allocatable arrays.
This is a partial fix for PR 21375i because I
have no idea how to deal with POINTER variables.
That is, the following now works with the patch
program a
integer i
integer, allocatable :: j(:)
deallocate(j,stat=i)
if (i /= 1) call abort
end program a
but the PR was concerned with a program of the form
program a
integer i
integer, pointer :: j
deallocate(j,stat=i)
if (i /= 1) call abort
end program a
I've spent several hours today trying to understand the
POINTER case, but have come up empty. All help is
gratefully accepted.
--
Steve
-------------- next part --------------
Index: trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.43
diff -c -p -r1.43 trans-array.c
*** trans-array.c 29 Apr 2005 15:31:38 -0000 1.43
--- trans-array.c 9 May 2005 00:48:26 -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
*** 3994,4003 ****
/* 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, integer_zero_node);
--- 3994,4006 ----
/* 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, integer_zero_node);
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 9 May 2005 00:48:26 -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.57
diff -c -p -r1.57 trans-decl.c
*** trans-decl.c 29 Apr 2005 15:31:37 -0000 1.57
--- trans-decl.c 9 May 2005 00:48:28 -0000
*************** gfc_build_builtin_function_decls (void)
*** 1889,1895 ****
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")),
--- 1900,1907 ----
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.28
diff -c -p -r1.28 trans-stmt.c
*** trans-stmt.c 1 Apr 2005 04:16:52 -0000 1.28
--- trans-stmt.c 9 May 2005 00:48:33 -0000
*************** gfc_trans_deallocate (gfc_code * code)
*** 3225,3236 ****
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;
--- 3218,3247 ----
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)
*** 3245,3251 ****
if (expr->symtree->n.sym->attr.dimension)
{
! tmp = gfc_array_deallocate (se.expr);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
--- 3256,3262 ----
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)
*** 3255,3269 ****
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);
}
--- 3266,3293 ----
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