re PR fortran/37507 (Print location in (DE)ALLOCATION errors)

2008-09-18  Daniel Kraft  <d@domob.eu>

	PR fortran/37507
	* trans.h (gfc_trans_runtime_error): New method.
	(gfc_trans_runtime_error_vararg): New method.
	(gfc_allocate_array_with_status): New argument `expr' for locus/varname.
	(gfc_deallocate_array_with_status): Ditto.
	* trans-array.h (gfc_array_deallocate): Ditto.
	* trans.c (gfc_trans_runtime_error): New method.
	(gfc_trans_runtime_error_vararg): New method, moved parts of the code
	from gfc_trans_runtime_check here.
	(gfc_trans_runtime_error_check): Moved code partly to new method.
	(gfc_call_malloc): Fix tab-indentation.
	(gfc_allocate_array_with_status): New argument `expr' and call
	gfc_trans_runtime_error for error reporting to include locus.
	(gfc_deallocate_with_status): Ditto.
	* trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument.
	* trans-array.c (gfc_array_allocate): Ditto.
	(gfc_array_deallocate): New argument `expr', passed on.
	(gfc_trans_dealloc_allocated): Pass NULL for expr.
	* trans-openmp.c (gfc_omp_clause_default): Ditto.

2008-09-18  Daniel Kraft  <d@domob.eu>

	PR fortran/37507
	* gfortran.dg/allocate_error_1.f90: New test.
	* gfortran.dg/deallocate_error_1.f90: New test.
	* gfortran.dg/deallocate_error_2.f90: New test.

From-SVN: r140451

gcc/fortran/ChangeLog

+2008-09-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37507
+	* trans.h (gfc_trans_runtime_error): New method.
+	(gfc_trans_runtime_error_vararg): New method.
+	(gfc_allocate_array_with_status): New argument `expr' for locus/varname.
+	(gfc_deallocate_array_with_status): Ditto.
+	* trans-array.h (gfc_array_deallocate): Ditto.
+	* trans.c (gfc_trans_runtime_error): New method.
+	(gfc_trans_runtime_error_vararg): New method, moved parts of the code
+	from gfc_trans_runtime_check here.
+	(gfc_trans_runtime_error_check): Moved code partly to new method.
+	(gfc_call_malloc): Fix tab-indentation.
+	(gfc_allocate_array_with_status): New argument `expr' and call
+	gfc_trans_runtime_error for error reporting to include locus.
+	(gfc_deallocate_with_status): Ditto.
+	* trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument.
+	* trans-array.c (gfc_array_allocate): Ditto.
+	(gfc_array_deallocate): New argument `expr', passed on.
+	(gfc_trans_dealloc_allocated): Pass NULL for expr.
+	* trans-openmp.c (gfc_omp_clause_default): Ditto.
+
 2008-09-18  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/37274

gcc/fortran/trans-array.c

@@ -3796,7 +3796,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
 
   /* The allocate_array variants take the old pointer as first argument.  */
   if (allocatable_array)
-    tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
+    tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
   else
     tmp = gfc_allocate_with_status (&se->pre, size, pstat);
   tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
@@ -3822,7 +3822,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
 /*GCC ARRAYS*/
 
 tree
-gfc_array_deallocate (tree descriptor, tree pstat)
+gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
 {
   tree var;
   tree tmp;
@@ -3834,7 +3834,7 @@ gfc_array_deallocate (tree descriptor, tree pstat)
   STRIP_NOPS (var);
 
   /* Parameter is the address of the data component.  */
-  tmp = gfc_deallocate_with_status (var, pstat, false);
+  tmp = gfc_deallocate_with_status (var, pstat, false, expr);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -5341,7 +5341,7 @@ gfc_trans_dealloc_allocated (tree descriptor)
   /* Call array_deallocate with an int * present in the second argument.
      Although it is ignored here, it's presence ensures that arrays that
      are already deallocated are ignored.  */
-  tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
+  tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */

gcc/fortran/trans-array.h

@@ -20,7 +20,7 @@ along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
 /* Generate code to free an array.  */
-tree gfc_array_deallocate (tree, tree);
+tree gfc_array_deallocate (tree, tree, gfc_expr*);
 
 /* 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-openmp.c

@@ -163,7 +163,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
   ptr = gfc_allocate_array_with_status (&cond_block,
 					build_int_cst (pvoid_type_node, 0),
-					size, NULL);
+					size, NULL, NULL);
   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
   then_b = gfc_finish_block (&cond_block);
 
@@ -215,7 +215,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
   ptr = gfc_allocate_array_with_status (&block,
 					build_int_cst (pvoid_type_node, 0),
-					size, NULL);
+					size, NULL, NULL);
   gfc_conv_descriptor_data_set (&block, dest, ptr);
   call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
 			  fold_convert (pvoid_type_node,
@@ -619,7 +619,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
       ptr = gfc_allocate_array_with_status (&block,
 					    build_int_cst (pvoid_type_node, 0),
-					    size, NULL);
+					    size, NULL, NULL);
       gfc_conv_descriptor_data_set (&block, decl, ptr);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
       stmt = gfc_finish_block (&block);

gcc/fortran/trans-stmt.c

@@ -4005,16 +4005,16 @@ gfc_trans_deallocate (gfc_code * code)
 		   && !(!last && expr->symtree->n.sym->attr.pointer))
 	    {
 	      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
-						expr->rank);
+					       expr->rank);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
 	}
 
       if (expr->rank)
-	tmp = gfc_array_deallocate (se.expr, pstat);
+	tmp = gfc_array_deallocate (se.expr, pstat, expr);
       else
 	{
-	  tmp = gfc_deallocate_with_status (se.expr, pstat, false);
+	  tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  tmp = fold_build2 (MODIFY_EXPR, void_type_node,

gcc/fortran/trans.c

@@ -347,17 +347,24 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
 }
 
 
-/* Generate a runtime error if COND is true.  */
+/* Generate a call to print a runtime error possibly including multiple
+   arguments and a locus.  */
 
-void
-gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
-		     locus * where, const char * msgid, ...)
+tree
+gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
 {
   va_list ap;
+
+  va_start (ap, msgid);
+  return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
+}
+
+tree
+gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
+				va_list ap)
+{
   stmtblock_t block;
-  tree body;
   tree tmp;
-  tree tmpvar = NULL;
   tree arg, arg2;
   tree *argarray;
   tree fntype;
@@ -365,9 +372,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
   const char *p;
   int line, nargs, i;
 
-  if (integer_zerop (cond))
-    return;
-
   /* Compute the number of extra arguments from the format string.  */
   for (p = msgid, nargs = 0; *p; p++)
     if (*p == '%')
@@ -377,14 +381,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 	  nargs++;
       }
 
-  if (once)
-    {
-       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
-       TREE_STATIC (tmpvar) = 1;
-       DECL_INITIAL (tmpvar) = boolean_true_node;
-       gfc_add_expr_to_block (pblock, tmpvar);
-    }
-
   /* The code to generate the error.  */
   gfc_start_block (&block);
 
@@ -411,9 +407,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
   argarray[0] = arg;
   argarray[1] = arg2;
-  va_start (ap, msgid);
   for (i = 0; i < nargs; i++)
-    argarray[2+i] = va_arg (ap, tree);
+    argarray[2 + i] = va_arg (ap, tree);
   va_end (ap);
   
   /* Build the function call to runtime_(warning,error)_at; because of the
@@ -432,6 +427,41 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 				 nargs + 2, argarray);
   gfc_add_expr_to_block (&block, tmp);
 
+  return gfc_finish_block (&block);
+}
+
+
+/* Generate a runtime error if COND is true.  */
+
+void
+gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
+			 locus * where, const char * msgid, ...)
+{
+  va_list ap;
+  stmtblock_t block;
+  tree body;
+  tree tmp;
+  tree tmpvar = NULL;
+
+  if (integer_zerop (cond))
+    return;
+
+  if (once)
+    {
+       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
+       TREE_STATIC (tmpvar) = 1;
+       DECL_INITIAL (tmpvar) = boolean_true_node;
+       gfc_add_expr_to_block (pblock, tmpvar);
+    }
+
+  gfc_start_block (&block);
+
+  /* The code to generate the error.  */
+  va_start (ap, msgid);
+  gfc_add_expr_to_block (&block,
+			 gfc_trans_runtime_error_vararg (error, where,
+							 msgid, ap));
+
   if (once)
     gfc_add_modify (&block, tmpvar, boolean_false_node);
 
@@ -524,30 +554,30 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
       void *newmem;
     
       if (stat)
-        *stat = 0;
+	*stat = 0;
 
       // The only time this can happen is the size wraps around.
       if (size < 0)
       {
-        if (stat)
-        {
-          *stat = LIBERROR_ALLOCATION;
-          newmem = NULL;
-        }
-        else
-          runtime_error ("Attempt to allocate negative amount of memory. "
-                         "Possible integer overflow");
+	if (stat)
+	{
+	  *stat = LIBERROR_ALLOCATION;
+	  newmem = NULL;
+	}
+	else
+	  runtime_error ("Attempt to allocate negative amount of memory. "
+			 "Possible integer overflow");
       }
       else
       {
-        newmem = malloc (MAX (size, 1));
-        if (newmem == NULL)
-        {
-          if (stat)
-            *stat = LIBERROR_ALLOCATION;
-          else
-            runtime_error ("Out of memory");
-        }
+	newmem = malloc (MAX (size, 1));
+	if (newmem == NULL)
+	{
+	  if (stat)
+	    *stat = LIBERROR_ALLOCATION;
+	  else
+	    runtime_error ("Out of memory");
+	}
       }
 
       return newmem;
@@ -668,13 +698,16 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 	}
 	else
 	  runtime_error ("Attempting to allocate already allocated array");
-    }  */
+    }
+    
+    expr must be set to the original expression being allocated for its locus
+    and variable name in case a runtime error has to be printed.  */
 tree
 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
-				tree status)
+				tree status, gfc_expr* expr)
 {
   stmtblock_t alloc_block;
-  tree res, tmp, null_mem, alloc, error, msg;
+  tree res, tmp, null_mem, alloc, error;
   tree type = TREE_TYPE (mem);
 
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
@@ -692,9 +725,23 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
   alloc = gfc_finish_block (&alloc_block);
 
   /* Otherwise, we issue a runtime error or set the status variable.  */
-  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
-			("Attempting to allocate already allocated array"));
-  error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+  if (expr)
+    {
+      tree varname;
+
+      gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempting to allocate already"
+				       " allocated array '%s'",
+				       varname);
+    }
+  else
+    error = gfc_trans_runtime_error (true, NULL,
+				     "Attempting to allocate already allocated"
+				     "array");
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
@@ -775,12 +822,16 @@ gfc_call_free (tree var)
    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
    even when no status variable is passed to us (this is used for
    unconditional deallocation generated by the front-end at end of
-   each procedure).  */
+   each procedure).
+   
+   If a runtime-message is possible, `expr' must point to the original
+   expression being deallocated for its locus and variable name.  */
 tree
-gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
+gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
+			    gfc_expr* expr)
 {
   stmtblock_t null, non_null;
-  tree cond, tmp, error, msg;
+  tree cond, tmp, error;
 
   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 		      build_int_cst (TREE_TYPE (pointer), 0));
@@ -790,10 +841,16 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
   gfc_start_block (&null);
   if (!can_fail)
     {
-      msg = gfc_build_addr_expr (pchar_type_node,
-				 gfc_build_localized_cstring_const
-				 ("Attempt to DEALLOCATE unallocated memory."));
-      error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+      tree varname;
+
+      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempt to DEALLOCATE unallocated '%s'",
+				       varname);
     }
   else
     error = build_empty_stmt ();

gcc/fortran/trans.h

@@ -450,6 +450,10 @@ void gfc_generate_constructors (void);
 /* Get the string length of an array constructor.  */
 bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
 
+/* Generate a runtime error call.  */
+tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
+tree gfc_trans_runtime_error_vararg (bool, locus*, const char*, va_list);
+
 /* Generate a runtime warning/error check.  */
 void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
 			      const char *, ...);
@@ -461,13 +465,13 @@ tree gfc_call_free (tree);
 tree gfc_call_malloc (stmtblock_t *, tree, tree);
 
 /* Allocate memory for arrays, with optional status variable.  */
-tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree);
+tree gfc_allocate_array_with_status (stmtblock_t*, tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
 tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
 
 /* Generate code to deallocate an array.  */
-tree gfc_deallocate_with_status (tree, tree, bool);
+tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
 
 /* Generate code to call realloc().  */
 tree gfc_call_realloc (stmtblock_t *, tree, tree);

gcc/testsuite/ChangeLog

+2008-09-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37507
+	* gfortran.dg/allocate_error_1.f90: New test.
+	* gfortran.dg/deallocate_error_1.f90: New test.
+	* gfortran.dg/deallocate_error_2.f90: New test.
+
 2008-09-18  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/37456

gcc/testsuite/gfortran.dg/allocate_error_1.f90

+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 13.*Attempting to allocate .* 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for ALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (arr(5))
+  ALLOCATE (arr(6))
+END PROGRAM main

gcc/testsuite/gfortran.dg/deallocate_error_1.f90

+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 14.*Attempt to DEALLOCATE unallocated 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (arr(5))
+  DEALLOCATE (arr)
+  DEALLOCATE (arr)
+END PROGRAM main

gcc/testsuite/gfortran.dg/deallocate_error_2.f90

+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 15.*Attempt to DEALLOCATE unallocated 'ptr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, POINTER :: ptr
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (ptr, arr(5))
+  DEALLOCATE (ptr)
+  DEALLOCATE (arr, ptr)
+END PROGRAM main