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

gcc/fortran/ChangeLog

+2009-03-30  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/38389
+	* 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.
+
 2009-03-30  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/22571

gcc/fortran/match.c

@@ -2222,11 +2222,13 @@ match
 gfc_match_allocate (void)
 {
   gfc_alloc *head, *tail;
-  gfc_expr *stat;
+  gfc_expr *stat, *errmsg, *tmp;
   match m;
+  bool saw_stat, saw_errmsg;
 
   head = tail = NULL;
-  stat = NULL;
+  stat = errmsg = tmp = NULL;
+  saw_stat = saw_errmsg = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
@@ -2250,35 +2252,92 @@ gfc_match_allocate (void)
       if (gfc_check_do_variable (tail->expr->symtree))
 	goto cleanup;
 
-      if (gfc_pure (NULL)
-	  && gfc_impure_variable (tail->expr->symtree->n.sym))
+      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
 	{
-	  gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
-		     "PURE procedure");
+	  gfc_error ("Bad allocate-object at %C for a PURE procedure");
 	  goto cleanup;
 	}
 
       if (tail->expr->ts.type == BT_DERIVED)
 	tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
 
+      /* FIXME: disable the checking on derived types and arrays.  */
+      if (!(tail->expr->ref
+	   && (tail->expr->ref->type == REF_COMPONENT
+	       || tail->expr->ref->type == REF_ARRAY)) 
+	  && tail->expr->symtree->n.sym
+	  && !(tail->expr->symtree->n.sym->attr.allocatable
+	       || tail->expr->symtree->n.sym->attr.pointer
+	       || tail->expr->symtree->n.sym->attr.proc_pointer))
+	{
+	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+		     "or an allocatable variable");
+	  goto cleanup;
+	}
+
       if (gfc_match_char (',') != MATCH_YES)
 	break;
 
-      m = gfc_match (" stat = %v", &stat);
+alloc_opt_list:
+
+      m = gfc_match (" stat = %v", &tmp);
       if (m == MATCH_ERROR)
 	goto cleanup;
       if (m == MATCH_YES)
-	break;
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  stat = tmp;
+	  saw_stat = true;
+
+	  if (gfc_check_do_variable (stat->symtree))
+	    goto cleanup;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+			      &tmp->where) == FAILURE)
+	    goto cleanup;
+
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
+	gfc_gobble_whitespace ();
+
+	if (gfc_peek_char () == ')')
+	  break;
     }
 
-  if (stat != NULL)
-    gfc_check_do_variable(stat->symtree);
 
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
   new_st.op = EXEC_ALLOCATE;
   new_st.expr = stat;
+  new_st.expr2 = errmsg;
   new_st.ext.alloc_list = head;
 
   return MATCH_YES;
@@ -2287,6 +2346,7 @@ syntax:
   gfc_syntax_error (ST_ALLOCATE);
 
 cleanup:
+  gfc_free_expr (errmsg);
   gfc_free_expr (stat);
   gfc_free_alloc_list (head);
   return MATCH_ERROR;
@@ -2367,11 +2427,13 @@ match
 gfc_match_deallocate (void)
 {
   gfc_alloc *head, *tail;
-  gfc_expr *stat;
+  gfc_expr *stat, *errmsg, *tmp;
   match m;
+  bool saw_stat, saw_errmsg;
 
   head = tail = NULL;
-  stat = NULL;
+  stat = errmsg = tmp = NULL;
+  saw_stat = saw_errmsg = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
@@ -2395,32 +2457,88 @@ gfc_match_deallocate (void)
       if (gfc_check_do_variable (tail->expr->symtree))
 	goto cleanup;
 
-      if (gfc_pure (NULL)
-	  && gfc_impure_variable (tail->expr->symtree->n.sym))
+      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
 	{
-	  gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
-		     "for a PURE procedure");
+	  gfc_error ("Illegal allocate-object at %C for a PURE procedure");
+	  goto cleanup;
+	}
+
+      /* FIXME: disable the checking on derived types.  */
+      if (!(tail->expr->ref
+	   && (tail->expr->ref->type == REF_COMPONENT
+	       || tail->expr->ref->type == REF_ARRAY)) 
+	  && tail->expr->symtree->n.sym
+	  && !(tail->expr->symtree->n.sym->attr.allocatable
+	       || tail->expr->symtree->n.sym->attr.pointer
+	       || tail->expr->symtree->n.sym->attr.proc_pointer))
+	{
+	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+		     "or an allocatable variable");
 	  goto cleanup;
 	}
 
       if (gfc_match_char (',') != MATCH_YES)
 	break;
 
-      m = gfc_match (" stat = %v", &stat);
+dealloc_opt_list:
+
+      m = gfc_match (" stat = %v", &tmp);
       if (m == MATCH_ERROR)
 	goto cleanup;
       if (m == MATCH_YES)
-	break;
-    }
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  stat = tmp;
+	  saw_stat = true;
+
+	  if (gfc_check_do_variable (stat->symtree))
+	    goto cleanup;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto dealloc_opt_list;
+	}
 
-  if (stat != NULL)
-    gfc_check_do_variable(stat->symtree);
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+			      &tmp->where) == FAILURE)
+	    goto cleanup;
+
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      gfc_free_expr (tmp);
+	      goto cleanup;
+	    }
+
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto dealloc_opt_list;
+	}
+
+	gfc_gobble_whitespace ();
+
+	if (gfc_peek_char () == ')')
+	  break;
+    }
 
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
   new_st.op = EXEC_DEALLOCATE;
   new_st.expr = stat;
+  new_st.expr2 = errmsg;
   new_st.ext.alloc_list = head;
 
   return MATCH_YES;
@@ -2429,6 +2547,7 @@ syntax:
   gfc_syntax_error (ST_DEALLOCATE);
 
 cleanup:
+  gfc_free_expr (errmsg);
   gfc_free_expr (stat);
   gfc_free_alloc_list (head);
   return MATCH_ERROR;

gcc/fortran/resolve.c

@@ -2034,16 +2034,16 @@ is_scalar_expr_ptr (gfc_expr *expr)
 		    }
 		  else
 		    {
-                  /* We have constant lower and upper bounds.  If the
-                     difference between is 1, it can be considered a
-                     scalar.  */
-                  start = (int) mpz_get_si
-                                (ref->u.ar.as->lower[0]->value.integer);
-                  end = (int) mpz_get_si
-                              (ref->u.ar.as->upper[0]->value.integer);
-                  if (end - start + 1 != 1)
-                    retval = FAILURE;
-                }
+		      /* We have constant lower and upper bounds.  If the
+			 difference between is 1, it can be considered a
+			 scalar.  */
+		      start = (int) mpz_get_si
+				(ref->u.ar.as->lower[0]->value.integer);
+		      end = (int) mpz_get_si
+				(ref->u.ar.as->upper[0]->value.integer);
+		      if (end - start + 1 != 1)
+			retval = FAILURE;
+		   }
                 }
               else
                 retval = FAILURE;
@@ -5181,8 +5181,8 @@ resolve_deallocate_expr (gfc_expr *e)
   if (allocatable == 0 && attr.pointer == 0)
     {
     bad:
-      gfc_error ("Expression in DEALLOCATE statement at %L must be "
-		 "ALLOCATABLE or a POINTER", &e->where);
+      gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+		 &e->where);
     }
 
   if (check_intent_in
@@ -5267,11 +5267,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
-    sym = code->expr->symtree->n.sym;
-  else
-    sym = NULL;
-
   /* Make sure the expression is allocatable or a pointer.  If it is
      pointer, the next-to-last reference must be a pointer.  */
 
@@ -5290,14 +5285,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       pointer = e->symtree->n.sym->attr.pointer;
       dimension = e->symtree->n.sym->attr.dimension;
 
-      if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
-	{
-	  gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
-		     "not be allocated in the same statement at %L",
-		      sym->name, &e->where);
-	  return FAILURE;
-	}
-
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
 	{
 	  if (pointer)
@@ -5328,8 +5315,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   if (allocatable == 0 && pointer == 0)
     {
-      gfc_error ("Expression in ALLOCATE statement at %L must be "
-		 "ALLOCATABLE or a POINTER", &e->where);
+      gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+		 &e->where);
       return FAILURE;
     }
 
@@ -5424,26 +5411,83 @@ check_symbols:
 static void
 resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 {
-  gfc_symbol *s = NULL;
-  gfc_alloc *a;
+  gfc_expr *stat, *errmsg, *pe, *qe;
+  gfc_alloc *a, *p, *q;
+
+  stat = code->expr ? code->expr : NULL;
 
-  if (code->expr)
-    s = code->expr->symtree->n.sym;
+  errmsg = code->expr2 ? code->expr2 : NULL;
 
-  if (s)
+  /* Check the stat variable.  */
+  if (stat)
     {
-      if (s->attr.intent == INTENT_IN)
-	gfc_error ("STAT variable '%s' of %s statement at %C cannot "
-		   "be INTENT(IN)", s->name, fcn);
+      if (stat->symtree->n.sym->attr.intent == INTENT_IN)
+	gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
+		   stat->symtree->n.sym->name, &stat->where);
 
-      if (gfc_pure (NULL) && gfc_impure_variable (s))
-	gfc_error ("Illegal STAT variable in %s statement at %C "
-		   "for a PURE procedure", fcn);
+      if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
+	gfc_error ("Illegal stat-variable at %L for a PURE procedure",
+		   &stat->where);
+
+      if (stat->ts.type != BT_INTEGER
+	  && !(stat->ref && (stat->ref->type == REF_ARRAY
+	       || stat->ref->type == REF_COMPONENT)))
+	gfc_error ("Stat-variable at %L must be a scalar INTEGER "
+		   "variable", &stat->where);
+
+      for (p = code->ext.alloc_list; p; p = p->next)
+	if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
+	  gfc_error ("Stat-variable at %L shall not be %sd within "
+		     "the same %s statement", &stat->where, fcn, fcn);
     }
 
-  if (s && code->expr->ts.type != BT_INTEGER)
-	gfc_error ("STAT tag in %s statement at %L must be "
-		       "of type INTEGER", fcn, &code->expr->where);
+  /* Check the errmsg variable.  */
+  if (errmsg)
+    {
+      if (!stat)
+	gfc_warning ("ERRMSG at %L is useless without a STAT tag",
+		     &errmsg->where);
+
+      if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
+	gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
+		   errmsg->symtree->n.sym->name, &errmsg->where);
+
+      if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
+	gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
+		   &errmsg->where);
+
+      if (errmsg->ts.type != BT_CHARACTER
+	  && !(errmsg->ref
+	       && (errmsg->ref->type == REF_ARRAY
+	  	   || errmsg->ref->type == REF_COMPONENT)))
+	gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+		   "variable", &errmsg->where);
+
+      for (p = code->ext.alloc_list; p; p = p->next)
+	if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
+	  gfc_error ("Errmsg-variable at %L shall not be %sd within "
+		     "the same %s statement", &errmsg->where, fcn, fcn);
+    }
+
+  /* Check that an allocate-object appears only once in the statement.  
+     FIXME: Checking derived types is disabled.  */
+  for (p = code->ext.alloc_list; p; p = p->next)
+    {
+      pe = p->expr;
+      if ((pe->ref && pe->ref->type != REF_COMPONENT)
+	   && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+	{
+	  for (q = p->next; q; q = q->next)
+	    {
+	      qe = q->expr;
+	      if ((qe->ref && qe->ref->type != REF_COMPONENT)
+		  && (qe->symtree->n.sym->ts.type != BT_DERIVED)
+		  && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
+		gfc_error ("Allocate-object at %L also appears at %L",
+			   &pe->where, &qe->where);
+	    }
+	}
+    }
 
   if (strcmp (fcn, "ALLOCATE") == 0)
     {
@@ -5457,6 +5501,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
     }
 }
 
+
 /************ SELECT CASE resolution subroutines ************/
 
 /* Callback function for our mergesort variant.  Determines interval

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

gcc/testsuite/ChangeLog

+2009-03-30  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/38389
+	* 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.
+
 2009-03-30  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/22571

gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90

@@ -18,9 +18,9 @@ program fc011
   integer, pointer :: PTR
   integer, allocatable :: ALLOCS(:)
 
-  allocate (PTR, stat=PTR) ! { dg-error "allocated in the same statement" }
+  allocate (PTR, stat=PTR) ! { dg-error "in the same ALLOCATE statement" }
 
-  allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "allocated in the same statement" }
+  allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "in the same ALLOCATE statement" }
 
   ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
 

gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90

+! { dg-do compile }
+program a
+
+  implicit none
+
+  real x
+  integer j, k, n(4)
+  character(len=70) err
+  character(len=70), allocatable :: error(:)
+
+  integer, allocatable :: i(:)
+
+  type b
+    integer, allocatable :: c(:), d(:)
+  end type b
+
+  type(b) e, f(3)
+
+  allocate(i(2), stat=x) ! { dg-error "must be a scalar INTEGER" }
+  allocate(i(2), stat=j, stat=k) ! { dg-error "Redundant STAT" }
+  allocate(i(2))
+  allocate(i(2))) ! { dg-error "Syntax error in ALLOCATE" }
+  allocate(i(2), errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+  allocate(i(2), errmsg=err) ! { dg-warning "useless without a STAT" }
+  allocate(i(2), stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+  allocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+  allocate(error(2),stat=j,errmsg=error) ! { dg-error "shall not be ALLOCATEd within" }
+  allocate(i(2), stat = i)  ! { dg-error "shall not be ALLOCATEd within" }
+
+  allocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+  allocate(i(2), i(2)) ! { dg-error "Allocate-object at" }
+
+  ! These should not fail the check for duplicate alloc-objects.
+  allocate(f(1)%c(2), f(2)%d(2))
+  allocate(e%c(2), e%d(2))
+
+end program a

gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90

+! { dg-do compile }
+subroutine sub(i, j, err)
+   implicit none
+   character(len=*), intent(in) :: err
+   integer, intent(in) :: j
+   integer, intent(in), allocatable :: i(:)
+   integer, allocatable :: m(:)
+   integer n
+   allocate(i(2))                    ! { dg-error "Cannot allocate" "" }
+   allocate(m(2), stat=j)            ! { dg-error "cannot be" "" }
+   allocate(m(2),stat=n,errmsg=err)  ! { dg-error "cannot be" "" }
+end subroutine sub

gcc/testsuite/gfortran.dg/allocate_alloc_opt_3.f90

+! { dg-do run }
+program a
+
+  implicit none
+
+  integer n
+  character(len=70) e1
+  character(len=30) e2
+  integer, allocatable :: i(:)
+
+  e1 = 'No error'
+  allocate(i(4), stat=n, errmsg=e1)
+  if (trim(e1) /= 'No error') call abort
+  deallocate(i)
+
+  e2 = 'No error'
+  allocate(i(4),stat=n, errmsg=e2)
+  if (trim(e2) /= 'No error') call abort
+  deallocate(i)
+
+
+  e1 = 'No error'
+  allocate(i(4), stat=n, errmsg=e1)
+  allocate(i(4), stat=n, errmsg=e1)
+  if (trim(e1) /= 'Attempt to allocate an allocated object') call abort
+  deallocate(i)
+
+  e2 = 'No error'
+  allocate(i(4), stat=n, errmsg=e2)
+  allocate(i(4), stat=n, errmsg=e2)
+  if (trim(e2) /= 'Attempt to allocate an allocat') call abort
+
+end program a

gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90

+! { dg-do compile }
+program a
+
+  implicit none
+
+  real x
+  integer j, k, n(4)
+  character(len=70) err
+  character(len=70), allocatable :: error(:)
+
+  integer, allocatable :: i(:)
+
+  type b
+    integer, allocatable :: c(:), d(:)
+  end type b
+
+  type(b) e, f(3)
+
+  deallocate(i, stat=x) ! { dg-error "must be a scalar INTEGER" }
+  deallocate(i, stat=j, stat=k) ! { dg-error "Redundant STAT" }
+  deallocate(i)
+  deallocate(i)) ! { dg-error "Syntax error in DEALLOCATE" }
+  deallocate(i, errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+  deallocate(i, errmsg=err) ! { dg-warning "useless without a STAT" }
+  deallocate(i, stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+  deallocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+  deallocate(error,stat=j,errmsg=error) ! { dg-error "shall not be DEALLOCATEd within" }
+  deallocate(i, stat = i)  ! { dg-error "shall not be DEALLOCATEd within" }
+
+  deallocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+  deallocate(i, i) ! { dg-error "Allocate-object at" }
+
+  ! These should not fail the check for duplicate alloc-objects.
+  deallocate(f(1)%c, f(2)%d)
+  deallocate(e%c, e%d)
+
+end program a

gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90

+! { dg-do compile }
+subroutine sub(i, j, err)
+   implicit none
+   character(len=*), intent(in) :: err
+   integer, intent(in) :: j
+   integer, intent(in), allocatable :: i(:)
+   integer, allocatable :: m(:)
+   integer n
+   deallocate(i)                    ! { dg-error "Cannot deallocate" "" }
+   deallocate(m, stat=j)            ! { dg-error "cannot be" "" }
+   deallocate(m,stat=n,errmsg=err)  ! { dg-error "cannot be" "" }
+end subroutine sub

gcc/testsuite/gfortran.dg/deallocate_alloc_opt_3.f90

+! { dg-do run }
+program a
+
+  implicit none
+
+  integer n
+  character(len=70) e1
+  character(len=30) e2
+  integer, allocatable :: i(:)
+
+  e1 = 'No error'
+  allocate(i(4))
+  deallocate(i, stat=n, errmsg=e1)
+  if (trim(e1) /= 'No error') call abort
+
+  e2 = 'No error'
+  allocate(i(4))
+  deallocate(i, stat=n, errmsg=e2)
+  if (trim(e2) /= 'No error') call abort
+
+  e1 = 'No error'
+  deallocate(i, stat=n, errmsg=e1)
+  if (trim(e1) /= 'Attempt to deallocate an unallocated object') call abort
+
+  e2 = 'No error'
+  deallocate(i, stat=n, errmsg=e2)
+  if (trim(e2) /= 'Attempt to deallocate an unall') call abort
+
+end program a