re PR fortran/30284 ([4.1 only] ICE in gfc_add_modify with internal reads)

2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	PR fortran/30626
	* trans-expr.c (gfc_conv_aliased_arg): Remove static attribute
	from function and make sure that substring lengths are
	translated.
	(is_aliased_array): Remove static attribute.
	* trans.c : Add prototypes for gfc_conv_aliased_arg and
	is_aliased_array.
	* trans-io.c (set_internal_unit): Add the post block to the
	arguments of the function.  Use is_aliased_array to check if
	temporary is needed; if so call gfc_conv_aliased_arg.
	(build_dt): Pass the post block to set_internal_unit and
	add to the block after all io activiy is done.

2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	PR fortran/30626
	* io/transfer.c (init_loop_spec, next_array_record): Change to
	lbound rather than unity base.

2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	* gfortran.dg/arrayio_11.f90.f90: New test.

	PR fortran/30626
	* gfortran.dg/arrayio_12.f90.f90: New test.

From-SVN: r121500

gcc/fortran/ChangeLog

+2007-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30284
+	PR fortran/30626
+	* trans-expr.c (gfc_conv_aliased_arg): Remove static attribute
+	from function and make sure that substring lengths are
+	translated.
+	(is_aliased_array): Remove static attribute.
+	* trans.c : Add prototypes for gfc_conv_aliased_arg and
+	is_aliased_array.
+	* trans-io.c (set_internal_unit): Add the post block to the
+	arguments of the function.  Use is_aliased_array to check if
+	temporary is needed; if so call gfc_conv_aliased_arg.
+	(build_dt): Pass the post block to set_internal_unit and
+	add to the block after all io activiy is done.
+
 2007-02-01  Roger Sayle  <roger@eyesopen.com>
 
 	* trans-array.c (gfc_conv_expr_descriptor): We don't need to use

gcc/fortran/trans-expr.c

@@ -1682,9 +1682,9 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    an actual argument derived type array is copied and then returned
    after the function call.
    TODO Get rid of this kludge, when array descriptors are capable of
-   handling aliased arrays.  */
+   handling arrays with a bigger stride in bytes than size.  */
 
-static void
+void
 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 		      int g77, sym_intent intent)
 {
@@ -1733,7 +1733,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
     {
       gfc_ref *char_ref = expr->ref;
 
-      for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
+      for (; char_ref; char_ref = char_ref->next)
 	if (char_ref->type == REF_SUBSTRING)
 	  {
 	    gfc_se tmp_se;
@@ -1928,7 +1928,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 /* Is true if an array reference is followed by a component or substring
    reference.  */
 
-static bool
+bool
 is_aliased_array (gfc_expr * e)
 {
   gfc_ref * ref;

gcc/fortran/trans-io.c

@@ -586,7 +586,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
    for an internal unit.  */
 
 static unsigned int
-set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
+set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
+		   tree var, gfc_expr * e)
 {
   gfc_se se;
   tree io;
@@ -624,10 +625,23 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
     {
       se.ss = gfc_walk_expr (e);
 
-      /* Return the data pointer and rank from the descriptor.  */
-      gfc_conv_expr_descriptor (&se, e, se.ss);
-      tmp = gfc_conv_descriptor_data_get (se.expr);
-      se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+      if (is_aliased_array (e))
+	{
+	  /* Use a temporary for components of arrays of derived types
+	     or substring array references.  */
+	  gfc_conv_aliased_arg (&se, e, 0,
+		last_dt == READ ? INTENT_IN : INTENT_OUT);
+	  tmp = build_fold_indirect_ref (se.expr);
+	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
+	  tmp = gfc_conv_descriptor_data_get (tmp);
+	}
+      else
+	{
+	  /* Return the data pointer and rank from the descriptor.  */
+	  gfc_conv_expr_descriptor (&se, e, se.ss);
+	  tmp = gfc_conv_descriptor_data_get (se.expr);
+	  se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+	}
     }
   else
     gcc_unreachable ();
@@ -635,10 +649,12 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
   /* The cast is needed for character substrings and the descriptor
      data.  */
   gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
-  gfc_add_modify_expr (&se.pre, len, se.string_length);
+  gfc_add_modify_expr (&se.pre, len,
+		       fold_convert (TREE_TYPE (len), se.string_length));
   gfc_add_modify_expr (&se.pre, desc, se.expr);
 
   gfc_add_block_to_block (block, &se.pre);
+  gfc_add_block_to_block (post_block, &se.post);
   return mask;
 }
 
@@ -1371,7 +1387,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 static tree
 build_dt (tree function, gfc_code * code)
 {
-  stmtblock_t block, post_block, post_end_block;
+  stmtblock_t block, post_block, post_end_block, post_iu_block;
   gfc_dt *dt;
   tree tmp, var;
   gfc_expr *nmlname;
@@ -1381,6 +1397,7 @@ build_dt (tree function, gfc_code * code)
   gfc_start_block (&block);
   gfc_init_block (&post_block);
   gfc_init_block (&post_end_block);
+  gfc_init_block (&post_iu_block);
 
   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
 
@@ -1411,7 +1428,8 @@ build_dt (tree function, gfc_code * code)
     {
       if (dt->io_unit->ts.type == BT_CHARACTER)
 	{
-	  mask |= set_internal_unit (&block, var, dt->io_unit);
+	  mask |= set_internal_unit (&block, &post_iu_block,
+				     var, dt->io_unit);
 	  set_parameter_const (&block, var, IOPARM_common_unit, 0);
 	}
       else
@@ -1502,6 +1520,8 @@ build_dt (tree function, gfc_code * code)
 
   gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
 
+  gfc_add_block_to_block (&block, &post_iu_block);
+
   dt_parm = NULL;
   dt_post_end_block = NULL;
 

gcc/fortran/trans.h

@@ -309,6 +309,10 @@ tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
 /* Also used to CALL subroutines.  */
 int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
 			    tree);
+
+void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
+bool is_aliased_array (gfc_expr *);
+
 /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
 
 /* Generate code for a scalar assignment.  */

gcc/testsuite/ChangeLog

+2007-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30284
+	* gfortran.dg/arrayio_11.f90.f90: New test.
+
+	PR fortran/30626
+	* gfortran.dg/arrayio_12.f90.f90: New test.
+
 2007-02-02  Jakub Jelinek  <jakub@redhat.com>
 
 	PR c++/30536

gcc/testsuite/gfortran.dg/arrayio_11.f90

+! { dg-do run }
+! Tests the fix for PR30284, in which the substring plus
+! component reference for an internal file would cause an ICE.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+
+program gfcbug51
+  implicit none
+
+  type :: date_t
+    character(len=12) :: date      ! yyyymmddhhmm
+  end type date_t
+
+  type year_t
+    integer :: year = 0
+  end type year_t
+
+  type(date_t) :: file(3)
+  type(year_t) :: time(3)
+
+  FILE%date = (/'200612231200', '200712231200', &
+                '200812231200'/)
+
+  time = date_to_year (FILE)
+  if (any (time%year .ne. (/2006, 2007, 2008/))) call abort ()
+
+  call month_to_date ((/8, 9, 10/), FILE)
+  if ( any (file%date .ne. (/'200608231200', '200709231200', &
+                             '200810231200'/))) call abort ()
+
+contains
+
+  function date_to_year (d) result (y)
+    type(date_t) :: d(3)
+    type(year_t) :: y(size (d, 1))
+    read (d%date(1:4),'(i4)')  time% year
+  end function date_to_year
+
+  subroutine month_to_date (m, d)
+    type(date_t) :: d(3)
+    integer :: m(:)
+    write (d%date(5:6),'(i2.2)')  m
+  end subroutine month_to_date
+
+end program gfcbug51

gcc/testsuite/gfortran.dg/arrayio_12.f90

+! { dg-do run }
+! Tests the fix for PR30626, in which the substring reference
+! for an internal file would cause an ICE.
+!
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+program gfcbug51
+  implicit none
+
+  character(len=12) :: cdate(3)      ! yyyymmddhhmm
+
+  type year_t
+    integer :: year = 0
+  end type year_t
+
+  type(year_t) :: time(3)
+
+  cdate = (/'200612231200', '200712231200', &
+            '200812231200'/)
+
+  time = date_to_year (cdate)
+  if (any (time%year .ne. (/2006, 2007, 2008/))) call abort ()
+
+  call month_to_date ((/8, 9, 10/), cdate)
+  if ( any (cdate .ne. (/'200608231200', '200709231200', &
+                         '200810231200'/))) call abort ()
+
+contains
+
+  function date_to_year (d) result (y)
+    character(len=12) :: d(3)
+    type(year_t) :: y(size (d, 1))
+    read (cdate(:)(1:4),'(i4)')  time% year
+  end function date_to_year
+
+  subroutine month_to_date (m, d)
+    character(len=12) :: d(3)
+    integer :: m(:)
+    write (cdate(:)(5:6),'(i2.2)')  m
+  end subroutine month_to_date
+
+end program gfcbug51

libgfortran/ChangeLog

+2007-02-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30284
+	PR fortran/30626
+	* io/transfer.c (init_loop_spec, next_array_record): Change to
+	lbound rather than unity base.
+
 2007-01-21  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* runtime/error.c: Include sys/time.h before sys/resource.h.

libgfortran/io/transfer.c

@@ -2013,7 +2013,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
   index = 1;
   for (i=0; i<rank; i++)
     {
-      ls[i].idx = 1;
+      ls[i].idx = desc->dim[i].lbound;
       ls[i].start = desc->dim[i].lbound;
       ls[i].end = desc->dim[i].ubound;
       ls[i].step = desc->dim[i].stride;
@@ -2050,8 +2050,9 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
           else
             carry = 0;
         }
-      index = index + (ls[i].idx - 1) * ls[i].step;
+      index = index + (ls[i].idx - ls[i].start) * ls[i].step;
     }
+
   return index;
 }