[patch, libfortran] PR 34565, internal write with negative strides

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

here's a patch for internal I/O with negative array strides.  This was
a bit tricky, due to the separation of stream I/O and the number of
places that needed to be touched.

Regression-tested on i686-pc-linux-gnu.

OK for trunk?

	Thomas

2008-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34565
	* io/io.h:  Adjust protoypes for open_internal(),
	next_array_record() and init_loop_spec().
	* io/list_read.c (next_char):  Use argument "finished"
	of next_array_record to check for end on internal file.
	* io/unit.c:  Calculate the offset for an array
	internal file and supply this informatin to open_internal().
	* io/unix.c (open_internal):  Set the offset for the internal
	file on open.
	* io/transfer.c (init_loop_spec):  Calculate the starting
	record in case of negative strides.  Return size of 0 for
	an empty array.
	(next_array_record):  Use an extra flag to signal that the
	array is finished.
	(next_record_r):  Use the new flag to next_array_record().
	(next_record_w):  Likewise.

2008-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34565
	* gfortran.dg/internal_readwrite_1.f90:  New test.
	* gfortran.dg/internal_readwrite_2.f90:  New test.

Index: list_read.c
===================================================================
--- list_read.c	(revision 131146)
+++ list_read.c	(working copy)
@@ -171,11 +171,14 @@ next_char (st_parameter_dt *dtp)
       /* Check for "end-of-record" condition.  */
       if (dtp->u.p.current_unit->bytes_left == 0)
 	{
+	  int finished;
+
 	  c = '\n';
-	  record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+	  record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+				      &finished);
 
 	  /* Check for "end-of-file" condition.  */      
-	  if (record == 0)
+	  if (finished)
 	    {
 	      dtp->u.p.at_eof = 1;
 	      goto done;
Index: io.h
===================================================================
--- io.h	(revision 131146)
+++ io.h	(working copy)
@@ -569,7 +569,7 @@ internal_proto(compare_files);
 extern stream *open_external (st_parameter_open *, unit_flags *);
 internal_proto(open_external);
 
-extern stream *open_internal (char *, int);
+extern stream *open_internal (char *, int, gfc_offset);
 internal_proto(open_internal);
 
 extern stream *input_stream (void);
@@ -734,10 +734,12 @@ internal_proto(read_sf);
 extern void *write_block (st_parameter_dt *, int);
 internal_proto(write_block);
 
-extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *);
+extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
+				     int*);
 internal_proto(next_array_record);
 
-extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *);
+extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
+				  gfc_offset *);
 internal_proto(init_loop_spec);
 
 extern void next_record (st_parameter_dt *, int);
Index: unit.c
===================================================================
--- unit.c	(revision 131146)
+++ unit.c	(working copy)
@@ -369,6 +369,7 @@ gfc_unit *
 get_internal_unit (st_parameter_dt *dtp)
 {
   gfc_unit * iunit;
+  gfc_offset start_record = 0;
 
   /* Allocate memory for a unit structure.  */
 
@@ -405,12 +406,15 @@ get_internal_unit (st_parameter_dt *dtp)
       iunit->ls = (array_loop_spec *)
 	get_mem (iunit->rank * sizeof (array_loop_spec));
       dtp->internal_unit_len *=
-	init_loop_spec (dtp->internal_unit_desc, iunit->ls);
+	init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
+
+      start_record *= iunit->recl;
     }
 
   /* Set initial values for unit parameters.  */
 
-  iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
+  iunit->s = open_internal (dtp->internal_unit - start_record,
+			    dtp->internal_unit_len, -start_record);
   iunit->bytes_left = iunit->recl;
   iunit->last_record=0;
   iunit->maxrec=0;
Index: unix.c
===================================================================
--- unix.c	(revision 131146)
+++ unix.c	(working copy)
@@ -1078,7 +1078,7 @@ empty_internal_buffer(stream *strm)
 /* open_internal()-- Returns a stream structure from an internal file */
 
 stream *
-open_internal (char *base, int length)
+open_internal (char *base, int length, gfc_offset offset)
 {
   int_stream *s;
 
@@ -1086,7 +1086,7 @@ open_internal (char *base, int length)
   memset (s, '\0', sizeof (int_stream));
 
   s->buffer = base;
-  s->buffer_offset = 0;
+  s->buffer_offset = offset;
 
   s->logical_offset = 0;
   s->active = s->file_length = length;
Index: transfer.c
===================================================================
--- transfer.c	(revision 131146)
+++ transfer.c	(working copy)
@@ -2061,42 +2061,63 @@ data_transfer_init (st_parameter_dt *dtp
 }
 
 /* Initialize an array_loop_spec given the array descriptor.  The function
-   returns the index of the last element of the array.  */
+   returns the index of the last element of the array, and also returns
+   starting record, where the first I/O goes to (necessary in case of
+   negative strides).  */
    
 gfc_offset
-init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
+init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
+		gfc_offset *start_record)
 {
   int rank = GFC_DESCRIPTOR_RANK(desc);
   int i;
   gfc_offset index; 
+  int empty;
 
+  empty = 0;
   index = 1;
+  *start_record = 0;
+
   for (i=0; i<rank; i++)
     {
       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;
-      
-      index += (desc->dim[i].ubound - desc->dim[i].lbound)
-                      * desc->dim[i].stride;
+      empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound);
+
+      if (desc->dim[i].stride > 0)
+	{
+	  index += (desc->dim[i].ubound - desc->dim[i].lbound)
+	    * desc->dim[i].stride;
+	}
+      else
+	{
+	  index -= (desc->dim[i].ubound - desc->dim[i].lbound)
+	    * desc->dim[i].stride;
+	  *start_record -= (desc->dim[i].ubound - desc->dim[i].lbound)
+	    * desc->dim[i].stride;
+	}
     }
-  return index;
+
+  if (empty)
+    return 0;
+  else
+    return index;
 }
 
 /* Determine the index to the next record in an internal unit array by
-   by incrementing through the array_loop_spec.  TODO:  Implement handling
-   negative strides. */
+   by incrementing through the array_loop_spec.  */
    
 gfc_offset
-next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
+next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
 {
   int i, carry;
   gfc_offset index;
   
   carry = 1;
   index = 0;
-  
+
   for (i = 0; i < dtp->u.p.current_unit->rank; i++)
     {
       if (carry)
@@ -2113,6 +2134,8 @@ next_array_record (st_parameter_dt *dtp,
       index = index + (ls[i].idx - ls[i].start) * ls[i].step;
     }
 
+  *finished = carry;
+
   return index;
 }
 
@@ -2234,7 +2257,10 @@ next_record_r (st_parameter_dt *dtp)
 	{
 	  if (is_array_io (dtp))
 	    {
-	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+	      int finished;
+
+	      record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+					  &finished);
 
 	      /* Now seek to this record.  */
 	      record = record * dtp->u.p.current_unit->recl;
@@ -2453,6 +2479,8 @@ next_record_w (st_parameter_dt *dtp, int
 	{
 	  if (is_array_io (dtp))
 	    {
+	      int finished;
+
 	      length = (int) dtp->u.p.current_unit->bytes_left;
 	      
 	      /* If the farthest position reached is greater than current
@@ -2476,8 +2504,9 @@ next_record_w (st_parameter_dt *dtp, int
 
 	      /* Now that the current record has been padded out,
 		 determine where the next record in the array is. */
-	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
-	      if (record == 0)
+	      record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+					  &finished);
+	      if (finished)
 		dtp->u.p.current_unit->endfile = AT_ENDFILE;
 	      
 	      /* Now seek to this record */

! { dg-do run }
! PR 34565 - internal writes with negative strides
! didn't work.
program main
  implicit none
  integer :: i
  integer :: lo, up, st
  character(len=2) :: c (5)
  integer, dimension(5) :: n
  c = (/ 'a', 'b', 'c', 'd', 'e' /)
  write (unit=c(5:1:-2),fmt="(A)") '5','3', '1'
  write (unit=c(2:4:2),fmt="(A)") '2', '4'
  read  (c(5:1:-1),fmt="(I2)") (n(i), i=5,1,-1)
  if (any(n /= (/ (i,i=1,5) /))) call abort
end program main

! { dg-do run }
! PR 34565 - intenal writes with negative strides.  This
! test case tries out a negative stride in a higher
! dimension.
program main
  implicit none
  integer :: i
  integer, parameter :: n1=2, n2=3, n3=5
  character(len=n1*n2*n3*2) :: line
  character(len=2), dimension(n1,n2,n3):: c
  write (unit=c(:,n2:1:-1,:),fmt="(I2)") (i,i=1,n1*n2*n3)
  line = transfer(c,mold=line)
  if (line /=" 5 6 3 4 1 21112 910 7 8171815161314232421221920293027282526") call abort
end program main