This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH] Fix FMT= with CHARACTER arrays (PR fortran/39865, take 2)


On Tue, May 12, 2009 at 03:14:14PM +0200, Jakub Jelinek wrote:
> The following patch attempts to fix it at least partially, for packed
> arrays.  The size computation should be correct even for non-packed arrays,
> but in that case we'd need to allocate a temporary and concatenate the array
> elements into it, possibly with a runtime check whether the temporary needs
> to be allocated and populated/freed.

And this updated patch instead should fix it fully, take care of the needed
packing if the array is not packed.
To avoid code duplication, I'm using gfc_conv_array_parameter function
which does almost what we want, except that it doesn't compute the array
size and the return value in se->expr isn't something from which it could be
computed.  So the patch adds an optional size outgoing argument, if
non-NULL, the size will be computed, all older callers just pass NULL.

Ok for trunk if testing succeeds?

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

	PR fortran/39865
	* io.c (resolve_tag_format): CHARACTER array in FMT= argument
	isn't an extension.
	* trans-array.c (gfc_array_parameter_size): New function.
	(gfc_conv_array_parameter): Add size argument.  Call
	gfc_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.

--- gcc/fortran/trans-array.c.jj	2009-05-04 16:46:11.000000000 +0200
+++ gcc/fortran/trans-array.c	2009-05-12 17:14:59.000000000 +0200
@@ -5336,13 +5336,41 @@ gfc_conv_expr_descriptor (gfc_se * se, g
   gfc_cleanup_loop (&loop);
 }
 
+/* Helper function for gfc_conv_array_parameter if array size needs to be
+   computed.  */
+
+static void
+gfc_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;
@@ -5391,6 +5419,8 @@ gfc_conv_array_parameter (gfc_se * se, g
             se->expr = tmp;
           else
 	    se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+	  if (size)
+	    gfc_array_parameter_size (tmp, expr, size);
 	  return;
         }
       if (sym->attr.allocatable)
@@ -5398,10 +5428,11 @@ gfc_conv_array_parameter (gfc_se * se, g
 	  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)
+	    gfc_array_parameter_size (tmp, expr, size);
+	  se->expr = gfc_conv_array_data (tmp);
           return;
         }
     }
@@ -5410,6 +5441,8 @@ gfc_conv_array_parameter (gfc_se * se, g
     {
       /* Result of the enclosing function.  */
       gfc_conv_expr_descriptor (se, expr, ss);
+      if (size)
+	gfc_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
@@ -5423,6 +5456,9 @@ gfc_conv_array_parameter (gfc_se * se, g
       /* Every other type of array.  */
       se->want_pointer = 1;
       gfc_conv_expr_descriptor (se, expr, ss);
+      if (size)
+	gfc_array_parameter_size (build_fold_indirect_ref (se->expr),
+				  expr, size);
     }
 
   /* Deallocate the allocatable components of structures that are
--- gcc/fortran/trans-io.c.jj	2009-05-04 16:46:12.000000000 +0200
+++ gcc/fortran/trans-io.c	2009-05-12 17:29:32.000000000 +0200
@@ -579,53 +579,51 @@ gfc_convert_array_to_string (gfc_se * se
   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)
     {
       gfc_conv_expr (se, e);
+      se->string_length
+	= fold_convert (gfc_charlen_type_node,
+			TYPE_SIZE_UNIT (TREE_TYPE (se->expr)));
+      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+      return;
     }
 
-  array = sym->backend_decl;
-  type = TREE_TYPE (array);
-
-  if (GFC_ARRAY_TYPE_P (type))
-    size = GFC_TYPE_ARRAY_SIZE (type);
-  else
+  if (0 && e->expr_type == EXPR_VARIABLE
+      && e->ref->u.ar.type == AR_FULL
+      && e->symtree
+      && e->symtree->n.sym->backend_decl
+      && GFC_DECL_PACKED_ARRAY (e->symtree->n.sym->backend_decl))
     {
-      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);
+      int rank = e->rank - 1;
 
-  /* 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_TREE, se->expr);
+      se->expr = gfc_get_symbol_decl (e->symtree->n.sym);
+      se->expr = gfc_conv_array_data (se->expr);
+      array = e->symtree->n.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);
+      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);
 }
 
--- gcc/fortran/trans-expr.c.jj	2009-05-04 16:46:11.000000000 +0200
+++ gcc/fortran/trans-expr.c	2009-05-12 16:36:14.000000000 +0200
@@ -2460,7 +2460,8 @@ gfc_conv_function_call (gfc_se * se, gfc
 	      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
@@ -2708,7 +2709,7 @@ gfc_conv_function_call (gfc_se * se, gfc
 			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.  */
@@ -4366,7 +4367,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, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
 
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
--- gcc/fortran/trans-intrinsic.c.jj	2009-05-04 16:46:12.000000000 +0200
+++ gcc/fortran/trans-intrinsic.c	2009-05-12 16:36:38.000000000 +0200
@@ -4392,7 +4392,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, 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, 
--- gcc/fortran/trans-array.h.jj	2008-11-03 09:16:03.000000000 +0100
+++ gcc/fortran/trans-array.h	2009-05-12 16:59:53.000000000 +0200
@@ -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 *);
 
--- gcc/fortran/io.c.jj	2008-12-27 10:12:25.000000000 +0100
+++ gcc/fortran/io.c	2009-05-12 14:39:59.000000000 +0200
@@ -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
 
@@ -1266,21 +1266,12 @@ 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 (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
-			  "in FORMAT tag at %L", &e->where) == FAILURE)
-	return FAILURE;
-    }
+  /* 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
+      && gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
+			 "in FORMAT tag at %L", &e->where) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
--- gcc/testsuite/gfortran.dg/pr39865.f90.jj	2009-05-12 14:25:33.000000000 +0200
+++ gcc/testsuite/gfortran.dg/pr39865.f90	2009-05-12 17:26:35.000000000 +0200
@@ -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.jj	2008-09-05 12:55:20.000000000 +0200
+++ gcc/testsuite/gfortran.dg/hollerith_f95.f90	2009-05-12 14:48:41.000000000 +0200
@@ -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/hollerith.f90.jj	2008-11-13 15:02:53.000000000 +0100
+++ gcc/testsuite/gfortran.dg/hollerith.f90	2009-05-12 14:46:55.000000000 +0200
@@ -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 }

	Jakub


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]