[PATCH] Fix for PR fortran/21375
Steve Kargl
sgk@troutmask.apl.washington.edu
Sun Jun 5 19:04:00 GMT 2005
On Sun, Jun 05, 2005 at 06:46:12PM +0100, Paul Brook wrote:
> > 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.
>
> >+ apstat = gfc_build_addr_expr (NULL, astat);
> >+ apstat = build_int_cst (gfc_int4_type_node, 0);
>
> This looks wrong. Assigning to a variable then immediately overwriting its
> value.
>
> Presumably there should be some library changes to go with this patch?
> It's also missing a ChangeLog entry.
>
> It would also be nice to have a comment that explained (in C or pseudocode)
> what we the code we generate should look like.
>
See patch.
2005-06-04 Steven G. Kargl <kargls@comcast.net>
PR fortran/17792
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/17792
PR fortran/21375
* gfortran.dg/pr21375.f90: New test.
--
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 18:56:46 -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 18:56:46 -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 18:56:48 -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 18:56:50 -0000
*************** gfc_trans_allocate (gfc_code * code)
*** 3288,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;
--- 3288,3342 ----
}
+ /* Translate a DEALLOCATE statement.
+ There are two cases within the the for loop:
+ (1) deallocate(a1, a2, a3) is translated into the following sequence
+ _gfortran_deallocate(a1, 0)
+ _gfortran_deallocate(a2, 0)
+ _gfortran_deallocate(a3, 0)
+ where the STAT= variable is passed a NULL pointer.
+ (2) deallocate(a1, a2, a3, stat=i) is translated into the following
+ _gfortran_deallocate(a1, &stat)
+ astat = sat
+ _gfortran_deallocate(a2, &stat)
+ astat = astat + stat
+ _gfortran_deallocate(a3, &stat)
+ astat = astat + stat
+ In case (1), we simply return at the end of the for loop. In case (2)
+ we set STAT= astat. */
tree
gfc_trans_deallocate (gfc_code * code)
{
+ int arg1 = 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)
+ {
+ /* Variable used with the library call. */
+ 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);
+
+ /* Running total of possible deallocation failures. */
+ astat = gfc_create_var (gfc_int4_type_node, "astat");
+ apstat = gfc_build_addr_expr (NULL, astat);
+ }
+ else
+ {
+ pstat = apstat = integer_zero_node;
+ stat = 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));
--- 3350,3356 ----
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);
--- 3358,3400 ----
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 (arg1 == 0)
! {
! /* Initialize the running total. */
! apstat = fold_convert (TREE_TYPE (stat), stat);
! arg1 = 1;
! }
! else
! {
! /* Add stat of the last deallocate to running total. */
! 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);
More information about the Fortran
mailing list