[multiple changes]

2006-03-22  Thomas Koenig  <Thomas.Koenig@onlien.de>

	PR fortran/19303
	* gfortran.h (gfc_option_t):  Add record_marker.
	* lang.opt:  Add -frecord-marker=4 and -frecord-marker=8.
	* trans-decl.c:  Add gfor_fndecl_set_record_marker.
	(gfc_build_builtin_function_decls): Set
	gfor_fndecl_set_record_marker.
	(gfc_generate_function_code):  If we are in the main program
	and -frecord-marker was provided, call set_record_marker.
	* options.c (gfc_handle_option):  Add handling for
	-frecord-marker=4 and -frecord-marker=8.
	* invoke.texi:  Document -frecord-marker.

2006-03-22  Thomas Koenig  <Thomas.Koenig@onlien.de>

	PR fortran/19303
	* libgfortran.h (compile_options_t):  Add record_marker.
	* runtime/compile_options.c (set_record_marker):
	New function.
	* io/open.c:  If we have four-byte record markers, use
	GFC_INTEGER_4_HUGE as default record length.
	* io/file_pos.c (unformatted_backspace):  Handle
	different size record markers.
	* io/transfer.c (us_read):  Likewise.
	(us_write):  Likewise.
	(next_record_r):  Likewise.
	(write_us_marker):  Likewise.
	(next_record_w):  Likewise.

2006-03-22  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/19303
	* gfortran.dg/record_marker_1.f90:  New test case.
	* gfortran.dg/record_marker_2.f:  New test case.
	* gfortran.dg/record_marker_3.f90:  New test case.

From-SVN: r112290

gcc/fortran/ChangeLog

@@ -1,7 +1,21 @@
+2006-03-22  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/19303
+	* gfortran.h (gfc_option_t):  Add record_marker.
+	* lang.opt:  Add -frecord-marker=4 and -frecord-marker=8.
+	* trans-decl.c:  Add gfor_fndecl_set_record_marker.
+	(gfc_build_builtin_function_decls): Set
+	gfor_fndecl_set_record_marker.
+	(gfc_generate_function_code):  If we are in the main program
+	and -frecord-marker was provided, call set_record_marker.
+	* options.c (gfc_handle_option):  Add handling for
+	-frecord-marker=4 and -frecord-marker=8.
+	* invoke.texi:  Document -frecord-marker.
+
 2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/17298
-	*trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
+	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
 	function to implement array valued TRANSFER intrinsic.
 	(gfc_conv_intrinsic_function): Call the new function if TRANSFER
 	and non-null se->ss.

gcc/fortran/gfortran.h

@@ -1641,6 +1641,7 @@ typedef struct
   int warn_nonstd_intrinsics;
   int fshort_enums;
   int convert;
+  int record_marker;
 }
 gfc_option_t;
 

gcc/fortran/invoke.texi

@@ -145,7 +145,7 @@ by type.  Explanations are in the following sections.
 @item Runtime Options
 @xref{Runtime Options,,Options for influencing runtime behavior}.
 @gccoptlist{
--fconvert=@var{conversion}}
+-fconvert=@var{conversion} -frecord-marker=@var{length}}
 
 @item Code Generation Options
 @xref{Code Gen Options,,Options for Code Generation Conventions}.
@@ -613,6 +613,17 @@ representation for unformatted files.
 @emph{This option has an effect only when used in the main program.
 The @code{CONVERT} specifier and the GFORTRAN_CONVERT_UNIT environment
 variable override the default specified by -fconvert.}
+
+@cindex -frecord-marker=@var{length}
+@item -frecord-marker=@var{length}
+Specify the length of record markers for unformatted files.
+Valid values for @var{length} are 4 and 8.  Default is whatever
+@code{off_t} is specified to be on that particular system.
+Note that specifying @var{length} as 4 limits the record
+length of unformatted files to 2 GB.  This option does not
+extend the maximum possible record length on systems where
+@code{off_t} is a four_byte quantity.
+
 @end table
 
 @node Code Gen Options

gcc/fortran/lang.opt

@@ -233,4 +233,12 @@ fconvert=swap
 Fortran RejectNegative
 Swap endianness for unformatted files
 
+frecord-marker=4
+Fortran RejectNegative
+Use a 4-byte record marker for unformatted files
+
+frecord-marker=8
+Fortran RejectNegative
+Use an 8-byte record marker for unformatted files
+
 ; This comment is to ensure we retain the blank line above.

gcc/fortran/options.c

@@ -615,6 +615,14 @@ gfc_handle_option (size_t scode, const char *arg, int value)
     case OPT_fconvert_swap:
       gfc_option.convert = CONVERT_SWAP;
       break;
+
+    case OPT_frecord_marker_4:
+      gfc_option.record_marker = 4;
+      break;
+
+    case OPT_frecord_marker_8:
+      gfc_option.record_marker = 8;
+      break;
     }
 
   return result;

gcc/fortran/trans-decl.c

@@ -93,6 +93,7 @@ tree gfor_fndecl_runtime_error;
 tree gfor_fndecl_set_fpe;
 tree gfor_fndecl_set_std;
 tree gfor_fndecl_set_convert;
+tree gfor_fndecl_set_record_marker;
 tree gfor_fndecl_ctime;
 tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
@@ -2297,6 +2298,10 @@ gfc_build_builtin_function_decls (void)
     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
 				     void_type_node, 1, gfc_c_int_type_node);
 
+  gfor_fndecl_set_record_marker =
+    gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
+				     void_type_node, 1, gfc_c_int_type_node);
+
   gfor_fndecl_in_pack = gfc_build_library_function_decl (
         get_identifier (PREFIX("internal_pack")),
         pvoid_type_node, 1, pvoid_type_node);
@@ -2943,6 +2948,21 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* If this is the main program and an -frecord-marker option was provided,
+     add a call to set_record_marker.  */
+
+  if (sym->attr.is_main_program && gfc_option.record_marker != 0)
+    {
+      tree arglist, gfc_c_int_type_node;
+
+      gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+      arglist = gfc_chainon_list (NULL_TREE,
+				  build_int_cst (gfc_c_int_type_node,
+						 gfc_option.record_marker));
+      tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
+      gfc_add_expr_to_block (&body, tmp);
+
+    }
 
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
       && sym->attr.subroutine)

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2006-03-22  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/19303
+	* gfortran.dg/record_marker_1.f90:  New test case.
+	* gfortran.dg/record_marker_2.f:  New test case.
+	* gfortran.dg/record_marker_3.f90:  New test case.
+
 2006-03-22  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/17298

gcc/testsuite/gfortran.dg/record_marker_1.f90

@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-options "-frecord-marker=4" }
+
+program main
+  implicit none
+  integer :: i1, i2, i3
+
+  open(15,form="UNFORMATTED")
+  write (15) 1
+  close (15)
+  open (15,form="UNFORMATTED",access="DIRECT",recl=4)
+  i1 = 1
+  i2 = 2
+  i3 = 3
+  read (15,rec=1) i1
+  read (15,rec=2) i2
+  read (15,rec=3) i3
+  close (15, status="DELETE")
+  if (i1 /= 4) call abort
+  if (i2 /= 1) call abort
+  if (i3 /= 4) call abort
+
+  open(15,form="UNFORMATTED",convert="SWAP")
+  write (15) 1
+  close (15)
+  open (15,form="UNFORMATTED",access="DIRECT",convert="SWAP",recl=4)
+  i1 = 1
+  i2 = 2
+  i3 = 3
+  read (15,rec=1) i1
+  read (15,rec=2) i2
+  read (15,rec=3) i3
+  close(15,status="DELETE")
+  if (i1 /= 4) call abort
+  if (i2 /= 1) call abort
+  if (i3 /= 4) call abort
+
+end program main

gcc/testsuite/gfortran.dg/record_marker_2.f

@@ -0,0 +1,83 @@
+! { dg-do run }
+! { dg-options "-frecord-marker=4" }
+! This file is all about BACKSPACE
+! Adapted from gfortran.dg/backspace.f
+
+      integer i, n, nr
+      real x(10), y(10)
+
+! PR libfortran/20068
+      open (20, status='scratch')
+      write (20,*) 1
+      write (20,*) 2
+      write (20,*) 3
+      rewind (20)
+      read (20,*) i
+      if (i .ne. 1) call abort
+      backspace (20)
+      read (20,*) i
+      if (i .ne. 1) call abort
+      close (20)
+
+! PR libfortran/20125
+      open (20, status='scratch')
+      write (20,*) 7
+      backspace (20)
+      read (20,*) i
+      if (i .ne. 7) call abort
+      close (20)
+
+      open (20, status='scratch', form='unformatted')
+      write (20) 8
+      backspace (20)
+      read (20) i
+      if (i .ne. 8) call abort
+      close (20)
+
+! PR libfortran/20471
+      do n = 1, 10
+        x(n) = sqrt(real(n))
+      end do
+      open (3, form='unformatted', status='scratch')
+      write (3) (x(n),n=1,10)
+      backspace (3)
+      rewind (3)
+      read (3) (y(n),n=1,10)
+
+      do n = 1, 10
+        if (abs(x(n)-y(n)) > 0.00001) call abort
+      end do
+      close (3)
+
+! PR libfortran/20156
+      open (3, form='unformatted', status='scratch')
+      do i = 1, 5
+        x(1) = i
+        write (3) n, (x(n),n=1,10)
+      end do
+      nr = 0
+      rewind (3)
+  20  continue
+      read (3,end=30,err=90) n, (x(n),n=1,10)
+      nr = nr + 1
+      goto 20
+  30  continue
+      if (nr .ne. 5) call abort
+
+      do i = 1, nr+1
+        backspace (3)
+      end do
+
+      do i = 1, nr
+        read(3,end=70,err=90) n, (x(n),n=1,10)
+        if (abs(x(1) - i) .gt. 0.001) call abort
+      end do
+      close (3)
+      stop
+
+  70  continue
+      call abort
+  90  continue
+      call abort
+
+      end

gcc/testsuite/gfortran.dg/record_marker_3.f90

@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-options "-frecord-marker=8" }
+
+program main
+  implicit none
+  integer (kind=8) :: i1, i2, i3
+
+  open(15,form="UNFORMATTED")
+  write (15) 1_8
+  close (15)
+  open (15,form="UNFORMATTED",access="DIRECT",recl=8)
+  i1 = 1
+  i2 = 2
+  i3 = 3
+  read (15,rec=1) i1
+  read (15,rec=2) i2
+  read (15,rec=3) i3
+  close (15, status="DELETE")
+  if (i1 /= 8) call abort
+  if (i2 /= 1) call abort
+  if (i3 /= 8) call abort
+
+  open(15,form="UNFORMATTED",convert="SWAP")
+  write (15) 1_8
+  close (15)
+  open (15,form="UNFORMATTED",access="DIRECT",convert="SWAP",recl=8)
+  i1 = 1
+  i2 = 2
+  i3 = 3
+  read (15,rec=1) i1
+  read (15,rec=2) i2
+  read (15,rec=3) i3
+  close(15,status="DELETE")
+  if (i1 /= 8) call abort
+  if (i2 /= 1) call abort
+  if (i3 /= 8) call abort
+
+end program main

libgfortran/ChangeLog

@@ -1,3 +1,19 @@
+2006-03-22  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/19303
+	* libgfortran.h (compile_options_t):  Add record_marker.
+	* runtime/compile_options.c (set_record_marker):
+	New function.
+	* io/open.c:  If we have four-byte record markers, use
+	GFC_INTEGER_4_HUGE as default record length.
+	* io/file_pos.c (unformatted_backspace):  Handle
+	different size record markers.
+	* io/transfer.c (us_read):  Likewise.
+	(us_write):  Likewise.
+	(next_record_r):  Likewise.
+	(write_us_marker):  Likewise.
+	(next_record_w):  Likewise.
+
 2006-03-20  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	PR fortran/20935

libgfortran/io/file_pos.c

@@ -104,21 +104,71 @@ static void
 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 {
   gfc_offset m, new;
-  int length;
+  GFC_INTEGER_4 m4;
+  GFC_INTEGER_8 m8;
+  int length, length_read;
   char *p;
 
+  if (compile_options.record_marker == 0)
     length = sizeof (gfc_offset);
+  else
+    length = compile_options.record_marker;
 
-  p = salloc_r_at (u->s, &length,
+  length_read = length;
+
+  p = salloc_r_at (u->s, &length_read,
 		   file_position (u->s) - length);
-  if (p == NULL)
+  if (p == NULL || length_read != length)
     goto io_error;
 
   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
   if (u->flags.convert == CONVERT_NATIVE)
-    memcpy (&m, p, sizeof (gfc_offset));
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
+	  memcpy (&m, p, sizeof(gfc_offset));
+	  break;
+
+	case sizeof(GFC_INTEGER_4):
+	  memcpy (&m4, p, sizeof (m4));
+	  m = m4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  memcpy (&m8, p, sizeof (m8));
+	  m = m8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
   else
-    reverse_memcpy (&m, p, sizeof (gfc_offset));
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
+	  reverse_memcpy (&m, p, sizeof(gfc_offset));
+	  break;
+
+	case sizeof(GFC_INTEGER_4):
+	  reverse_memcpy (&m4, p, sizeof (m4));
+	  m = m4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  reverse_memcpy (&m8, p, sizeof (m8));
+	  m = m8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+
+    }
 
   if ((new = file_position (u->s) - m - 2*length) < 0)
     new = 0;

libgfortran/io/open.c

@@ -399,7 +399,26 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
     u->recl = opp->recl_in;
   else
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
 	  u->recl = max_offset;
+	  break;
+
+	case sizeof (GFC_INTEGER_4):
+	  u->recl = GFC_INTEGER_4_HUGE;
+	  break;
+
+	case sizeof (GFC_INTEGER_8):
+	  u->recl = max_offset;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
 
   /* If the file is direct access, calculate the maximum record number
      via a division now instead of letting the multiplication overflow

libgfortran/io/transfer.c

@@ -1230,12 +1230,21 @@ us_read (st_parameter_dt *dtp)
 {
   char *p;
   int n;
+  int nr;
+  GFC_INTEGER_4 i4;
+  GFC_INTEGER_8 i8;
   gfc_offset i;
 
   if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
     return;
 
+  if (compile_options.record_marker == 0)
     n = sizeof (gfc_offset);
+  else
+    n = compile_options.record_marker;
+
+  nr = n;
+
   p = salloc_r (dtp->u.p.current_unit->s, &n);
 
   if (n == 0)
@@ -1244,7 +1253,7 @@ us_read (st_parameter_dt *dtp)
       return;  /* end of file */
     }
 
-  if (p == NULL || n != sizeof (gfc_offset))
+  if (p == NULL || n != nr)
     {
       generate_error (&dtp->common, ERROR_BAD_US, NULL);
       return;
@@ -1252,9 +1261,49 @@ us_read (st_parameter_dt *dtp)
 
   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
-    memcpy (&i, p, sizeof (gfc_offset));
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
+	  memcpy (&i, p, sizeof(gfc_offset));
+	  break;
+
+	case sizeof(GFC_INTEGER_4):
+	  memcpy (&i4, p, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  memcpy (&i8, p, sizeof (i8));
+	  i = i8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
   else
-    reverse_memcpy (&i, p, sizeof (gfc_offset));
+      switch (compile_options.record_marker)
+	{
+	case 0:
+	  reverse_memcpy (&i, p, sizeof(gfc_offset));
+	  break;
+
+	case sizeof(GFC_INTEGER_4):
+	  reverse_memcpy (&i4, p, sizeof (i4));
+	  i = i4;
+	  break;
+
+	case sizeof(GFC_INTEGER_8):
+	  reverse_memcpy (&i8, p, sizeof (i8));
+	  i = i8;
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
 
   dtp->u.p.current_unit->bytes_left = i;
 }
@@ -1270,7 +1319,11 @@ us_write (st_parameter_dt *dtp)
   gfc_offset dummy;
 
   dummy = 0;
+
+  if (compile_options.record_marker == 0)
     nbytes = sizeof (gfc_offset);
+  else
+    nbytes = compile_options.record_marker ;
 
   if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
     generate_error (&dtp->common, ERROR_OS, NULL);
@@ -1673,7 +1726,9 @@ next_record_r (st_parameter_dt *dtp)
     case UNFORMATTED_SEQUENTIAL:
 
       /* Skip over tail */
-      dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset);
+      dtp->u.p.current_unit->bytes_left +=
+	compile_options.record_marker == 0 ?
+	sizeof (gfc_offset) : compile_options.record_marker;
       
       /* Fall through...  */
 
@@ -1773,20 +1828,72 @@ next_record_r (st_parameter_dt *dtp)
 
 
 /* Small utility function to write a record marker, taking care of
-   byte swapping.  */
+   byte swapping and of choosing the correct size.  */
 
 inline static int
 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
 {
-  size_t len = sizeof (gfc_offset);
+  size_t len;
+  GFC_INTEGER_4 buf4;
+  GFC_INTEGER_8 buf8;
+  char p[sizeof (GFC_INTEGER_8)];
+
+  if (compile_options.record_marker == 0)
+    len = sizeof (gfc_offset);
+  else
+    len = compile_options.record_marker;
+
   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
   if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
 	  return swrite (dtp->u.p.current_unit->s, &buf, &len);
-  else {
-    gfc_offset p;
-    reverse_memcpy (&p, &buf, sizeof (gfc_offset));
-    return swrite (dtp->u.p.current_unit->s, &p, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_4):
+	  buf4 = buf;
+	  return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_8):
+	  buf8 = buf;
+	  return swrite (dtp->u.p.current_unit->s, &buf8, &len);
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
 	}
+    }
+  else
+    {
+      switch (compile_options.record_marker)
+	{
+	case 0:
+	  reverse_memcpy (p, &buf, sizeof (gfc_offset));
+	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_4):
+	  buf4 = buf;
+	  reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
+	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  break;
+
+	case sizeof (GFC_INTEGER_8):
+	  buf8 = buf;
+	  reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
+	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  break;
+
+	default:
+	  runtime_error ("Illegal value for record marker");
+	  break;
+	}
+    }
+
 }
 
 
@@ -1798,6 +1905,7 @@ next_record_w (st_parameter_dt *dtp, int done)
   gfc_offset c, m, record, max_pos;
   int length;
   char *p;
+  size_t record_marker;
 
   /* Zero counters for X- and T-editing.  */
   max_pos = dtp->u.p.max_pos;
@@ -1830,10 +1938,15 @@ next_record_w (st_parameter_dt *dtp, int done)
       if (write_us_marker (dtp, m) != 0)
 	goto io_error;
 
+      if (compile_options.record_marker == 4)
+	record_marker = sizeof(GFC_INTEGER_4);
+      else
+	record_marker = sizeof (gfc_offset);
+
       /* Seek to the head and overwrite the bogus length with the real
 	 length.  */
 
-      if (sseek (dtp->u.p.current_unit->s, c - m - sizeof (gfc_offset))
+      if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
 	  == FAILURE)
 	goto io_error;
 
@@ -1842,7 +1955,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 
       /* Seek past the end of the current record.  */
 
-      if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
+      if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
 	goto io_error;
 
       break;

libgfortran/libgfortran.h

@@ -338,6 +338,7 @@ typedef struct
   int allow_std;
   int pedantic;
   int convert;
+  size_t record_marker;
 }
 compile_options_t;
 

libgfortran/runtime/compile_options.c

@@ -74,3 +74,29 @@ set_convert (int conv)
 {
   compile_options.convert = conv;
 }
+
+extern void set_record_marker (int);
+export_proto (set_record_marker);
+
+
+void
+set_record_marker (int val)
+{
+
+  switch(val)
+    {
+    case 4:
+      if (sizeof (GFC_INTEGER_4) != sizeof (gfc_offset))
+	compile_options.record_marker = sizeof (GFC_INTEGER_4);
+      break;
+
+    case 8:
+      if (sizeof (GFC_INTEGER_8) != sizeof (gfc_offset))
+	compile_options.record_marker = sizeof (GFC_INTEGER_8);
+      break;
+
+    default:
+      runtime_error ("Invalid value for record marker");
+      break;
+    }
+}