2009-05-14  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/39865
	* io.c (resolve_tag_format): CHARACTER array in FMT= argument
	isn't an extension.  Reject non-CHARACTER array element of
	assumed shape or pointer or assumed size array.
	* trans-array.c (array_parameter_size): New function.
	(gfc_conv_array_parameter): Add size argument.  Call
	array_parameter_size if it is non-NULL.
	* trans-array.h (gfc_conv_array_parameter): Adjust prototype.
	* trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign):
	Adjust callers.
	* trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise.
	* trans-io.c (gfc_convert_array_to_string): Rewritten.

	* gfortran.dg/pr39865.f90: New test.
	* gfortran.dg/hollerith.f90: Don't expect errors for CHARACTER
	arrays in FMT=.
	* gfortran.dg/hollerith_f95.f90: Likewise.
	* gfortran.dg/hollerith6.f90: New test.
	* gfortran.dg/hollerith7.f90: New test.

--- gcc/fortran/trans-expr.c	(revision 147506)
+++ gcc/fortran/trans-expr.c	(revision 147507)
@@ -1979,7 +1979,7 @@ gfc_conv_function_call (gfc_se * se, gfc
 		gfc_conv_aliased_arg (&parmse, e, f,
 			fsym ? fsym->attr.intent : INTENT_INOUT);
 	      else
-	        gfc_conv_array_parameter (&parmse, e, argss, f);
+	        gfc_conv_array_parameter (&parmse, e, argss, f, NULL);
 	    } 
 	}
 
@@ -3115,7 +3115,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * e
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
-  gfc_conv_array_parameter (&se, expr1, ss, 0);
+  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL);
 
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
--- gcc/fortran/trans-array.c	(revision 147506)
+++ gcc/fortran/trans-array.c	(revision 147507)
@@ -4491,11 +4491,42 @@ gfc_conv_expr_descriptor (gfc_se * se, g
 }
 
 
+/* Helper function for gfc_conv_array_parameter if array size needs to be
+   computed.  */
+
+static void
+array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+{
+  tree elem;
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+    *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+  else if (expr->rank > 1)
+    {
+      *size = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL, desc));
+      *size = gfc_build_function_call (gfor_fndecl_size0, *size);
+    }
+  else
+    {
+      tree ubound = gfc_conv_descriptor_ubound (desc, gfc_index_zero_node);
+      tree lbound = gfc_conv_descriptor_lbound (desc, gfc_index_zero_node);
+
+      *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+      *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
+			   gfc_index_one_node);
+      *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
+			   gfc_index_zero_node);
+    }
+  elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
+		       fold_convert (gfc_array_index_type, elem));
+}
+
 /* Convert an array for passing as an actual parameter.  */
 /* TODO: Optimize passing g77 arrays.  */
 
 void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+			  tree *size)
 {
   tree ptr;
   tree desc;
@@ -4522,17 +4553,23 @@ gfc_conv_array_parameter (gfc_se * se, g
             se->expr = tmp;
           else
 	    se->expr = gfc_build_addr_expr (NULL, tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
 	  return;
         }
       if (sym->attr.allocatable)
         {
           se->expr = gfc_conv_array_data (tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
           return;
         }
     }
 
   se->want_pointer = 1;
   gfc_conv_expr_descriptor (se, expr, ss);
+  if (size)
+    array_parameter_size (build_fold_indirect_ref (se->expr), expr, size);
 
   if (g77)
     {
--- gcc/fortran/trans-array.h	(revision 147506)
+++ gcc/fortran/trans-array.h	(revision 147507)
@@ -94,7 +94,7 @@ void gfc_conv_tmp_ref (gfc_se *);
 /* Evaluate an array expression.  */
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
 /* Convert an array for passing as an actual function parameter.  */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int);
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int, tree *);
 /* Evaluate and transpose a matrix expression.  */
 void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
 
--- gcc/fortran/io.c	(revision 147506)
+++ gcc/fortran/io.c	(revision 147507)
@@ -1072,8 +1072,11 @@ resolve_tag (const io_tag * tag, gfc_exp
       /* If e's rank is zero and e is not an element of an array, it should be
 	 of integer or character type.  The integer variable should be
 	 ASSIGNED.  */
-      if (e->symtree == NULL || e->symtree->n.sym->as == NULL
-		|| e->symtree->n.sym->as->rank == 0)
+      if (e->rank == 0
+	  && (e->expr_type != EXPR_VARIABLE
+	      || e->symtree == NULL
+	      || e->symtree->n.sym->as == NULL
+	      || e->symtree->n.sym->as->rank == 0))
 	{
 	  if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
 	    {
@@ -1109,19 +1112,35 @@ resolve_tag (const io_tag * tag, gfc_exp
 	  /* if rank is nonzero, we allow the type to be character under
 	     GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
 	     assigned an Hollerith constant.  */
-	  if (e->ts.type == BT_CHARACTER)
-	    {
-	      if (gfc_notify_std (GFC_STD_GNU,
-			"Extension: Character array in FORMAT tag at %L",
-			&e->where) == FAILURE)
-		return FAILURE;
-	    }
-	  else
+	  if (e->ts.type != BT_CHARACTER)
 	    {
 	      if (gfc_notify_std (GFC_STD_LEGACY,
 			"Extension: Non-character in FORMAT tag at %L",
 			&e->where) == FAILURE)
 		return FAILURE;
+
+	      if (e->rank == 0
+		  && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
+		{
+		  gfc_error ("Non-character assumed shape array element in FORMAT"
+			     " tag at %L", &e->where);
+		  return FAILURE;
+		}
+
+	      if (e->rank == 0
+		  && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+		{
+		  gfc_error ("Non-character assumed size array element in FORMAT"
+			     " tag at %L", &e->where);
+		  return FAILURE;
+		}
+
+	      if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
+		{
+		  gfc_error ("Non-character pointer array element in FORMAT tag at %L",
+			     &e->where);
+		  return FAILURE;
+		}
 	    }
 	  return SUCCESS;
 	}
--- gcc/fortran/trans-io.c	(revision 147506)
+++ gcc/fortran/trans-io.c	(revision 147507)
@@ -447,64 +447,57 @@ set_parameter_ref (stmtblock_t *block, s
 
 /* Given an array expr, find its address and length to get a string. If the
    array is full, the string's address is the address of array's first element
-   and the length is the size of the whole array. If it is an element, the
+   and the length is the size of the whole array.  If it is an element, the
    string's address is the element's address and the length is the rest size of
-   the array.
-*/
+   the array.  */
 
 static void
 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
 {
-  tree tmp;
-  tree array;
-  tree type;
   tree size;
-  int rank;
-  gfc_symbol *sym;
-
-  sym = e->symtree->n.sym;
-  rank = sym->as->rank - 1;
 
-  if (e->ref->u.ar.type == AR_FULL)
-    {
-      se->expr = gfc_get_symbol_decl (sym);
-      se->expr = gfc_conv_array_data (se->expr);
-    }
-  else
+  if (e->rank == 0)
     {
+      tree type, array, tmp;
+      gfc_symbol *sym;
+      int rank;
+
+      /* If it is an element, we need its address and size of the rest.  */
+      gcc_assert (e->expr_type == EXPR_VARIABLE);
+      gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
+      sym = e->symtree->n.sym;
+      rank = sym->as->rank - 1;
       gfc_conv_expr (se, e);
-    }
 
-  array = sym->backend_decl;
-  type = TREE_TYPE (array);
+      array = sym->backend_decl;
+      type = TREE_TYPE (array);
 
-  if (GFC_ARRAY_TYPE_P (type))
-    size = GFC_TYPE_ARRAY_SIZE (type);
-  else
-    {
-      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-      size = gfc_conv_array_stride (array, rank);
-      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-		gfc_conv_array_ubound (array, rank),
-		gfc_conv_array_lbound (array, rank));
-      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
-		gfc_index_one_node);
-      size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);      
-    }
-
-  gcc_assert (size);
+      if (GFC_ARRAY_TYPE_P (type))
+	size = GFC_TYPE_ARRAY_SIZE (type);
+      else
+	{
+	  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+	  size = gfc_conv_array_stride (array, rank);
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_array_ubound (array, rank),
+			     gfc_conv_array_lbound (array, rank));
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+			     gfc_index_one_node);
+	  size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
+	}
+      gcc_assert (size);
 
-  /* If it is an element, we need the its address and size of the rest.  */
-  if (e->ref->u.ar.type == AR_ELEMENT)
-    {
       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
-		TREE_OPERAND (se->expr, 1));
-      se->expr = gfc_build_addr_expr (NULL, se->expr);
+			  TREE_OPERAND (se->expr, 1));
+      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+			  fold_convert (gfc_array_index_type, tmp));
+      se->string_length = fold_convert (gfc_charlen_type_node, size);
+      return;
     }
 
-  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
-  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
-
+  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, &size);
   se->string_length = fold_convert (gfc_charlen_type_node, size);
 }
 
@@ -533,7 +526,9 @@ set_string (stmtblock_t * block, stmtblo
 		NULL_TREE);
 
   /* Integer variable assigned a format label.  */
-  if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
+  if (e->ts.type == BT_INTEGER
+      && e->rank == 0
+      && e->symtree->n.sym->attr.assign == 1)
     {
       char * msg;
 
@@ -557,7 +552,7 @@ set_string (stmtblock_t * block, stmtblo
       if (e->ts.type == BT_CHARACTER && e->rank == 0)
 	gfc_conv_expr (&se, e);
       /* Array assigned Hollerith constant or character array.  */
-      else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
+      else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
 	gfc_convert_array_to_string (&se, e);
       else
 	gcc_unreachable ();
--- gcc/fortran/trans-intrinsic.c	(revision 147506)
+++ gcc/fortran/trans-intrinsic.c	(revision 147507)
@@ -2937,7 +2937,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (&argse, arg->expr);
   else
-    gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
+    gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
   ptr = argse.expr;
@@ -3515,7 +3515,7 @@ gfc_conv_intrinsic_loc(gfc_se * se, gfc_
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (se, arg_expr);
   else
-    gfc_conv_array_parameter (se, arg_expr, ss, 1); 
+    gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL); 
   se->expr= convert (gfc_unsigned_type (long_integer_type_node), 
 		     se->expr);
    
--- gcc/testsuite/gfortran.dg/hollerith6.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/hollerith6.f90	(revision 147507)
@@ -0,0 +1,35 @@
+! PR fortran/39865
+! { dg-do run }
+
+subroutine foo (a)
+  integer(kind=4) :: a(1, 3)
+  character(len=40) :: t
+  write (t, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
+  if (t .ne. '   1   2   3   4   5   6   7   8') call abort
+end subroutine foo
+  interface
+    subroutine foo (a)
+      integer(kind=4) :: a(1, 3)
+    end subroutine foo
+  end interface
+  integer(kind=4) :: b(1,3)
+  character(len=40) :: t
+  b(1,1) = 4HXXXX
+  b(1,2) = 4H (8I
+  b(1,3) = 2H4)
+  write (t, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
+  if (t .ne. '   1   2   3   4   5   6   7   8') call abort
+  call foo (b)
+end
+
+! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 7 }
+! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 20 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 17 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 18 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 19 }
--- gcc/testsuite/gfortran.dg/hollerith.f90	(revision 147506)
+++ gcc/testsuite/gfortran.dg/hollerith.f90	(revision 147507)
@@ -99,10 +99,4 @@ end subroutine
 
 ! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 39 }
 
-! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 43 }
-
-! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 45 }
-
-! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 47 }
-
 ! { dg-warning "Hollerith constant" "" { target *-*-* } 51 }
--- gcc/testsuite/gfortran.dg/pr39865.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/pr39865.f90	(revision 147507)
@@ -0,0 +1,84 @@
+! PR fortran/39865
+! { dg-do run }
+
+subroutine f1 (a)
+  character(len=1) :: a(7:)
+  character(len=12) :: b
+  character(len=1) :: c(2:10)
+  write (b, a) 'Hell', 'o wo', 'rld!'
+  if (b .ne. 'Hello world!') call abort
+  write (b, a(:)) 'hell', 'o Wo', 'rld!'
+  if (b .ne. 'hello World!') call abort
+  write (b, a(8:)) 'Hell', 'o wo', 'rld!'
+  if (b .ne. 'Hello world!') call abort
+  c(2) = ' '
+  c(3) = '('
+  c(4) = '3'
+  c(5) = 'A'
+  c(6) = '4'
+  c(7) = ')'
+  write (b, c) 'hell', 'o Wo', 'rld!'
+  if (b .ne. 'hello World!') call abort
+  write (b, c(:)) 'Hell', 'o wo', 'rld!'
+  if (b .ne. 'Hello world!') call abort
+  write (b, c(3:)) 'hell', 'o Wo', 'rld!'
+  if (b .ne. 'hello World!') call abort
+end subroutine f1
+
+subroutine f2 (a)
+  character(len=1) :: a(10:,20:)
+  character(len=12) :: b
+  write (b, a) 'Hell', 'o wo', 'rld!'
+  if (b .ne. 'Hello world!') call abort
+  write (b, a) 'hell', 'o Wo', 'rld!'
+  if (b .ne. 'hello World!') call abort
+end subroutine f2
+
+function f3 ()
+  character(len=1) :: f3(5)
+  f3(1) = '('
+  f3(2) = '3'
+  f3(3) = 'A'
+  f3(4) = '4'
+  f3(5) = ')'
+end function f3
+
+  interface
+    subroutine f1 (a)
+      character(len=1) :: a(:)
+    end
+  end interface
+  interface
+    subroutine f2 (a)
+      character(len=1) :: a(:,:)
+    end
+  end interface
+  interface
+    function f3 ()
+      character(len=1) :: f3(5)
+    end
+  end interface
+  integer :: i, j
+  character(len=1) :: e (6, 7:9), f (3,2), g (10)
+  character(len=12) :: b
+  e = 'X'
+  e(2,8) = ' '
+  e(3,8) = '('
+  e(4,8) = '3'
+  e(2,9) = 'A'
+  e(3,9) = '4'
+  e(4,9) = ')'
+  f = e(2:4,8:9)
+  g = 'X'
+  g(2) = ' '
+  g(3) = '('
+  g(4) = '3'
+  g(5) = 'A'
+  g(6) = '4'
+  g(7) = ')'
+  call f1 (g(2:7))
+  call f2 (f)
+  call f2 (e(2:4,8:9))
+  write (b, f3 ()) 'Hell', 'o wo', 'rld!'
+  if (b .ne. 'Hello world!') call abort
+end
--- gcc/testsuite/gfortran.dg/hollerith_f95.f90	(revision 147506)
+++ gcc/testsuite/gfortran.dg/hollerith_f95.f90	(revision 147507)
@@ -91,10 +91,3 @@ end subroutine
 ! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 38 }
 
 ! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 40 }
-
-! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 44 }
-
-! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 46 }
-
-! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 48 }
-
--- gcc/testsuite/gfortran.dg/hollerith7.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/hollerith7.f90	(revision 147507)
@@ -0,0 +1,52 @@
+! PR fortran/39865
+! { dg-do compile }
+
+subroutine foo (a)
+  integer(kind=4), target :: a(1:, 1:)
+  integer(kind=4), pointer :: b(:, :)
+  b => a
+  write (*, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
+  write (*, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
+end subroutine foo
+subroutine bar (a, b)
+  character :: b(2,*)
+  integer :: a(*)
+  write (*, fmt=b) 1, 2, 3
+  write (*, fmt=a) 1, 2, 3
+  write (*, fmt=a(2)) 1, 2, 3
+end subroutine
+  interface
+    subroutine foo (a)
+      integer(kind=4), target :: a(:, :)
+    end subroutine foo
+  end interface
+  integer(kind=4) :: a(2, 3)
+  a = 4HXXXX
+  a(2,2) = 4H (8I
+  a(1,3) = 2H4)
+  a(2,3) = 1H 
+  call foo (a(2:2,:))
+end
+
+! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 8 }
+! { dg-error "Non-character assumed shape array element in FORMAT tag" "element" { target *-*-* } 8 }
+
+! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 9 }
+! { dg-error "Non-character pointer array element in FORMAT tag" "element" { target *-*-* } 9 }
+
+! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 14 }
+! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 15 }
+! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 16 }
+! { dg-error "Non-character assumed size array element in FORMAT tag" "element" { target *-*-* } 16 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 24 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 25 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 25 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 26 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 26 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 27 }