[PATCH] Fix for PR fortran/21375
Steve Kargl
sgk@troutmask.apl.washington.edu
Tue Jun 7 21:47:00 GMT 2005
On Tue, Jun 07, 2005 at 10:13:00PM +0200, Tobias Schl?ter wrote:
> Steve Kargl wrote:
> >
> > I agree. But in my 10+ hours of trying to figure out how tree-ssa
> > stuff works, I never stumbled on the magic incantation on how to
> > initialize a variable.
>
> I thought that
> gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
> would work or is something else the problem?
>
Oh, so that's how you initialize a variable. :-)
See new patch. It initializes astat and removes the special
case for the first argument.
Bootstrap and regtested.
OK for mainline? Ok for 4.0.1 with Mark's approval?
--
Steve
-------------- next part --------------
Index: trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.48
diff -c -p -r1.48 trans-array.c
*** trans-array.c 5 Jun 2005 18:03:40 -0000 1.48
--- trans-array.c 7 Jun 2005 21:40:49 -0000
*************** gfc_array_allocate (gfc_se * se, gfc_ref
*** 2778,2784 ****
/*GCC ARRAYS*/
tree
! gfc_array_deallocate (tree descriptor)
{
tree var;
tree tmp;
--- 2778,2784 ----
/*GCC ARRAYS*/
tree
! gfc_array_deallocate (tree descriptor, tree pstat)
{
tree var;
tree tmp;
*************** gfc_array_deallocate (tree descriptor)
*** 2793,2799 ****
/* 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);
--- 2793,2799 ----
/* 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
*** 4023,4032 ****
/* 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,
--- 4023,4035 ----
/* 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 7 Jun 2005 21:40:49 -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 7 Jun 2005 21:40:51 -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 7 Jun 2005 21:40:53 -0000
*************** gfc_trans_allocate (gfc_code * code)
*** 3288,3293 ****
--- 3288,3310 ----
}
+ /* Translate a DEALLOCATE statement.
+ There are two cases within 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
+ astat = 0
+ _gfortran_deallocate(a1, &stat)
+ astat = astat + stat
+ _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)
{
*************** 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;
--- 3312,3345 ----
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);
+
+ /* Initialize astat to 0. */
+ gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+ }
+ 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));
--- 3353,3359 ----
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);
--- 3361,3393 ----
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 by adding stat
! of the last deallocation to the running total. */
! if (code->expr)
! {
! 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