re PR fortran/39865 (ICE in gfc_conv_scalarized_array_ref)

	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.

From-SVN: r147507

13 files changed, 311 insertions, 80 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0798407..db5f373 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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.
+
 2009-05-13  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* gfortran.h (gfc_code): Rename struct member expr to expr1.
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index eb0e3ae..c902257 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1,5 +1,5 @@
 /* Deal with I/O statements & related stuff.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -1234,8 +1234,11 @@ resolve_tag_format (const gfc_expr *e)
   /* 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)
 	{
@@ -1266,20 +1269,34 @@ resolve_tag_format (const gfc_expr *e)
       return SUCCESS;
     }
 
-  /* 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 rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
+     It may be assigned an Hollerith constant.  */
+  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;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 71db46d..f4276ca 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5339,13 +5339,41 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   gfc_cleanup_loop (&loop);
 }
 
+/* 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 = build_call_expr (gfor_fndecl_size0, 1,
+			     gfc_build_addr_expr (NULL, desc));
+  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,
-			  const gfc_symbol *fsym, const char *proc_name)
+			  const gfc_symbol *fsym, const char *proc_name,
+			  tree *size)
 {
   tree ptr;
   tree desc;
@@ -5394,6 +5422,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
             se->expr = tmp;
           else
 	    se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
 	  return;
         }
       if (sym->attr.allocatable)
@@ -5401,10 +5431,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
 	  if (sym->attr.dummy || sym->attr.result)
 	    {
 	      gfc_conv_expr_descriptor (se, expr, ss);
-	      se->expr = gfc_conv_array_data (se->expr);
+	      tmp = se->expr;
 	    }
-	  else
-	    se->expr = gfc_conv_array_data (tmp);
+	  if (size)
+	    array_parameter_size (tmp, expr, size);
+	  se->expr = gfc_conv_array_data (tmp);
           return;
         }
     }
@@ -5413,6 +5444,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
     {
       /* Result of the enclosing function.  */
       gfc_conv_expr_descriptor (se, expr, ss);
+      if (size)
+	array_parameter_size (se->expr, expr, size);
       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 
       if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
@@ -5426,6 +5459,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
       /* Every other type of array.  */
       se->want_pointer = 1;
       gfc_conv_expr_descriptor (se, expr, ss);
+      if (size)
+	array_parameter_size (build_fold_indirect_ref (se->expr),
+				  expr, size);
     }
 
   /* Deallocate the allocatable components of structures that are
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 49818d4..3f8809d 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -106,7 +106,7 @@ void gfc_conv_tmp_ref (gfc_se *);
 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,
-			       const gfc_symbol *, const char *);
+			       const gfc_symbol *, const char *, tree *);
 /* Evaluate and transpose a matrix expression.  */
 void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 70c44f3..cf17598 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2424,7 +2424,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      f = f || !sym->attr.always_explicit;
 	  
 	      argss = gfc_walk_expr (arg->expr);
-	      gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
+	      gfc_conv_array_parameter (se, arg->expr, argss, f,
+					NULL, NULL, NULL);
 	    }
 
 	  /* TODO -- the following two lines shouldn't be necessary, but
@@ -2676,7 +2677,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			fsym ? fsym->attr.intent : INTENT_INOUT);
 	      else
 	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
-					  sym->name);
+					  sym->name, NULL);
 
               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                  allocated on entry, it must be deallocated.  */
@@ -4352,7 +4353,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
-  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
 
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index d00a35b..33cc7f5 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4394,7 +4394,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (se, arg_expr);
   else
-    gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL); 
+    gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 09f35b7..24f156e 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -567,65 +567,57 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
 
 /* 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);
 
-  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);      
-    }
+      array = sym->backend_decl;
+      type = TREE_TYPE (array);
 
-  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));
+			  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,
-		      fold_convert (gfc_array_index_type, tmp));
-
+  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size);
   se->string_length = fold_convert (gfc_charlen_type_node, size);
 }
 
@@ -654,7 +646,9 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 		     var, p->field_len, 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;
       tree cond;
@@ -680,7 +674,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
       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 ();
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f9580aa..fe0bb00 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2009-05-14  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/39865
+	* 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.
+
 2009-05-14  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
 	PR cpp/36674
diff --git a/gcc/testsuite/gfortran.dg/hollerith.f90 b/gcc/testsuite/gfortran.dg/hollerith.f90
index f983615..21cbf66 100644
--- a/gcc/testsuite/gfortran.dg/hollerith.f90
+++ b/gcc/testsuite/gfortran.dg/hollerith.f90
@@ -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 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith6.f90 b/gcc/testsuite/gfortran.dg/hollerith6.f90
new file mode 100644
index 0000000..93e857dd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith6.f90
@@ -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 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith7.f90 b/gcc/testsuite/gfortran.dg/hollerith7.f90
new file mode 100644
index 0000000..8e2fb4f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith7.f90
@@ -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 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith_f95.f90 b/gcc/testsuite/gfortran.dg/hollerith_f95.f90
index 1ba7403..4d7fda8 100644
--- a/gcc/testsuite/gfortran.dg/hollerith_f95.f90
+++ b/gcc/testsuite/gfortran.dg/hollerith_f95.f90
@@ -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 }
-
diff --git a/gcc/testsuite/gfortran.dg/pr39865.f90 b/gcc/testsuite/gfortran.dg/pr39865.f90
new file mode 100644
index 0000000..fac3436
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr39865.f90
@@ -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