diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a8e6972fba1fd613599415a12738ab2d03df14df..af1d05f6fabe44e6459a2331cecb575f9b00447d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2005-06-11 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-07 Jerry DeLisle <jvdelisle@verizon.net>
* intrinsic.texi: Add documentation for dcmplx, digits,
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3554107ab832dd41c8ebbca14f79b50a9517fca9..ea5ec524fb57909eefbe64499c90a669c6850095 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2778,7 +2778,7 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor)
+gfc_array_deallocate (tree descriptor, tree pstat)
{
tree var;
tree tmp;
@@ -2793,7 +2793,7 @@ gfc_array_deallocate (tree descriptor)
/* 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_chainon_list (tmp, pstat);
tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
@@ -4026,7 +4026,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
gfc_start_block (&block);
/* Deallocate if still allocated at the end of the procedure. */
- deallocate = gfc_array_deallocate (descriptor);
+ deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
tmp = gfc_conv_descriptor_data (descriptor);
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index faaaf5ade4b082b29ef18123dfcc589fc8b73368..95a69f369b48ae6da0e5675139ec78d7866c0f77 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -20,7 +20,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA. */
/* Generate code to free an array. */
-tree gfc_array_deallocate (tree);
+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. */
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 9b2b669a5b262ee6c2def488bcb43e0ad88a4b2a..5aca960d88399c512330dbc538a875b143c91f5b 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1873,6 +1873,7 @@ gfc_build_builtin_function_decls (void)
tree gfc_int4_type_node = gfc_get_int_type (4);
tree gfc_int8_type_node = gfc_get_int_type (8);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
+ tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
gfor_fndecl_internal_malloc =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
@@ -1899,7 +1900,8 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
- void_type_node, 1, ppvoid_type_node);
+ void_type_node, 2, ppvoid_type_node,
+ gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 85f2660bf7c9a9b307260ef34672416a052367dc..55543182f8d32ec9e218a40633b76f22f4f46e2c 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3288,19 +3288,56 @@ gfc_trans_allocate (gfc_code * code)
}
+/* 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, 0B)
+ _gfortran_deallocate(a2, 0B)
+ _gfortran_deallocate(a3, 0B)
+ 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_se se;
gfc_alloc *al;
gfc_expr *expr;
- tree var;
- tree tmp;
- tree type;
+ tree apstat, astat, parm, pstat, stat, tmp, type, var;
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);
+
+ /* Variable used with the library call. */
+ 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 = null_pointer_node;
+ stat = astat = NULL_TREE;
+ }
+
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->expr;
@@ -3314,10 +3351,7 @@ gfc_trans_deallocate (gfc_code * code)
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);
- }
+ tmp = gfc_array_deallocate (se.expr, pstat);
else
{
type = build_pointer_type (TREE_TYPE (se.expr));
@@ -3325,13 +3359,33 @@ gfc_trans_deallocate (gfc_code * code)
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);
+ 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);