re PR fortran/17792 ([4.0 only] deallocate does not return stat)

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.

From-SVN: r100845

gcc/fortran/ChangeLog

+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,

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, 

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.  */

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")),

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);