alloc_alloc_expr_1.f90: Adjust for new error message.

2008-12-10  Steven G. Kargl  <kargls@comcast.net>

	* gfortran.dg/alloc_alloc_expr_1.f90: Adjust for new error message.
	* gfortran.dg/allocate_alloc_opt_1.f90: New test.
	* gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/allocate_alloc_opt_3.f90: Ditto.
	* gfortran.dg/deallocate_alloc_opt_1.f90: Ditto.
	* gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/deallocate_alloc_opt_3.f90: Ditto.


2008-12-10  Steven G. Kargl  <kargls@comcast.net>

	* trans-stmt.c(gfc_trans_allocate): Add translation of ERRMSG.
	(gfc_trans_deallocate): Add translation of ERRMSG.  Remove stale
	comments.  Minor whitespace cleanup.
	* resolve.c(is_scalar_expr_ptr): Whitespace cleanup.
	(resolve_deallocate_expr (gfc_expr *e): Update error message.
	(resolve_allocate_expr):  Remove dead code.  Update error message.
	Move error checking to ...
	(resolve_allocate_deallocate): ... here.  Add additional error
	checking for STAT, ERRMSG, and allocate-objects.
	* match.c(gfc_match_allocate,gfc_match_deallocate):  Parse ERRMSG.
	Check for redundant uses of STAT and ERRMSG.  Reword error message
	and add checking for pointer, allocatable, and proc_pointer attributes.

From-SVN: r145331

1 files changed, 81 insertions, 33 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 0e51bdacc43..24e7b80be19 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3932,9 +3932,12 @@ gfc_trans_allocate (gfc_code * code)
   if (!code->ext.alloc_list)
     return NULL_TREE;
 
+  pstat = stat = error_label = tmp = NULL_TREE;
+
   gfc_start_block (&block);
 
-  if (code->expr)
+  /* Either STAT= and/or ERRMSG is present.  */
+  if (code->expr || code->expr2)
     {
       tree gfc_int4_type_node = gfc_get_int_type (4);
 
@@ -3944,8 +3947,6 @@ gfc_trans_allocate (gfc_code * code)
       error_label = gfc_build_label_decl (NULL_TREE);
       TREE_USED (error_label) = 1;
     }
-  else
-    pstat = stat = error_label = NULL_TREE;
 
   for (al = code->ext.alloc_list; al != NULL; al = al->next)
     {
@@ -3971,7 +3972,7 @@ gfc_trans_allocate (gfc_code * code)
 			     fold_convert (TREE_TYPE (se.expr), tmp));
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
-	  if (code->expr)
+	  if (code->expr || code->expr2)
 	    {
 	      tmp = build1_v (GOTO_EXPR, error_label);
 	      parm = fold_build2 (NE_EXPR, boolean_type_node,
@@ -3994,7 +3995,7 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* Assign the value to the status variable.  */
+  /* STAT block.  */
   if (code->expr)
     {
       tmp = build1_v (LABEL_EXPR, error_label);
@@ -4006,29 +4007,45 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_modify (&block, se.expr, tmp);
     }
 
+  /* ERRMSG block.  */
+  if (code->expr2)
+    {
+      /* A better error message may be possible, but not required.  */
+      const char *msg = "Attempt to allocate an allocated object";
+      tree errmsg, slen, dlen;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr2);
+
+      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+      gfc_add_modify (&block, errmsg,
+		gfc_build_addr_expr (pchar_type_node,
+			gfc_build_localized_cstring_const (msg)));
+
+      slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+      dlen = gfc_get_expr_charlen (code->expr2);
+      slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+      dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+		gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+      tmp = fold_build2 (NE_EXPR, boolean_type_node, stat,
+			 build_int_cst (TREE_TYPE (stat), 0));
+
+      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
   return gfc_finish_block (&block);
 }
 
 
-/* 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.  */
+/* Translate a DEALLOCATE statement.  */
+
 tree
-gfc_trans_deallocate (gfc_code * code)
+gfc_trans_deallocate (gfc_code *code)
 {
   gfc_se se;
   gfc_alloc *al;
@@ -4036,14 +4053,17 @@ gfc_trans_deallocate (gfc_code * code)
   tree apstat, astat, pstat, stat, tmp;
   stmtblock_t block;
 
+  pstat = apstat = stat = astat = tmp = NULL_TREE;
+
   gfc_start_block (&block);
 
-  /* Set up the optional STAT= */
-  if (code->expr)
+  /* Count the number of failed deallocations.  If deallocate() was
+     called with STAT= , then set STAT to the count.  If deallocate
+     was called with ERRMSG, then set ERRMG to a string.  */
+  if (code->expr || code->expr2)
     {
       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_TREE, stat);
 
@@ -4054,8 +4074,6 @@ gfc_trans_deallocate (gfc_code * code)
       /* Initialize astat to 0.  */
       gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
     }
-  else
-    pstat = apstat = stat = astat = NULL_TREE;
 
   for (al = code->ext.alloc_list; al != NULL; al = al->next)
     {
@@ -4069,8 +4087,7 @@ gfc_trans_deallocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (expr->ts.type == BT_DERIVED
-	    && expr->ts.derived->attr.alloc_comp)
+      if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
         {
 	  gfc_ref *ref;
 	  gfc_ref *last = NULL;
@@ -4081,7 +4098,7 @@ gfc_trans_deallocate (gfc_code * code)
 	  /* Do not deallocate the components of a derived type
 	     ultimate pointer component.  */
 	  if (!(last && last->u.c.component->attr.pointer)
-		   && !(!last && expr->symtree->n.sym->attr.pointer))
+		&& !(!last && expr->symtree->n.sym->attr.pointer))
 	    {
 	      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
 					       expr->rank);
@@ -4104,7 +4121,7 @@ gfc_trans_deallocate (gfc_code * code)
 
       /* Keep track of the number of failed deallocations by adding stat
 	 of the last deallocation to the running total.  */
-      if (code->expr)
+      if (code->expr || code->expr2)
 	{
 	  apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
 	  gfc_add_modify (&se.pre, astat, apstat);
@@ -4115,7 +4132,7 @@ gfc_trans_deallocate (gfc_code * code)
 
     }
 
-  /* Assign the value to the status variable.  */
+  /* Set STAT.  */
   if (code->expr)
     {
       gfc_init_se (&se, NULL);
@@ -4124,6 +4141,37 @@ gfc_trans_deallocate (gfc_code * code)
       gfc_add_modify (&block, se.expr, tmp);
     }
 
+  /* Set ERRMSG.  */
+  if (code->expr2)
+    {
+      /* A better error message may be possible, but not required.  */
+      const char *msg = "Attempt to deallocate an unallocated object";
+      tree errmsg, slen, dlen;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr2);
+
+      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+      gfc_add_modify (&block, errmsg,
+		gfc_build_addr_expr (pchar_type_node,
+                        gfc_build_localized_cstring_const (msg)));
+
+      slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+      dlen = gfc_get_expr_charlen (code->expr2);
+      slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+      dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+		gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+      tmp = fold_build2 (NE_EXPR, boolean_type_node, astat,
+			 build_int_cst (TREE_TYPE (astat), 0));
+
+      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
   return gfc_finish_block (&block);
 }