[fortran, patch] PR 19303 - implement four-byte record markers
Thomas Koenig
Thomas.Koenig@online.de
Wed Mar 15 22:25:00 GMT 2006
:ADDPATCH fortran:
Hello world,
after the discussion on four-byte record markers, here is a patch
to implement them. Regression-tested on i686-pc-linux-gnu. Documentation
checked with "make" and "make dvi".
OK for trunk? Do we want this on 4.1?
Thomas
2006-03-15 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-15 Thomas Koenig <Thomas.Koenig@onlien.de>
PR fortran/19303
* libgfortran.h (compile_options_t): Add record_marker.
* runtime/compile_options.c: Add set_record_marker.
* io/file_pos.c (unformatted_backspace): Handle
four-byte record markers.
* io/open.c: If we have four-byte record markers, use
GFC_INTEGER_4_HUGE as default record length.
* io/transfer.c (us_read): Likewise.
(us_write): Likewise.
(next_record_r): Likewise.
(write_us_marker): Likewise.
(next_record_w): Likewise.
2006-03-15 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.
-------------- next part --------------
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 111963)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1638,6 +1638,7 @@ typedef struct
int warn_nonstd_intrinsics;
int fshort_enums;
int convert;
+ int record_marker;
}
gfc_option_t;
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt (revision 111963)
+++ gcc/fortran/lang.opt (working copy)
@@ -225,4 +225,12 @@ fconvert=swap
Fortran RejectNegative
Swap endianness for unformatted files
+frecord-marker=4
+Fortran RejectNegative
+Use a 4-byte recordr marker for unformatted files
+
+frecord-marker=8
+Fortran RejectNegative
+Use a 8-byte record marker for unformatted files
+
; This comment is to ensure we retain the blank line above.
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi (revision 111963)
+++ gcc/fortran/invoke.texi (working copy)
@@ -145,7 +145,7 @@ by type. Explanations are in the follow
@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}.
@@ -591,6 +591,14 @@ 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 8.
+Note that specifying @var{length} as 4 limits the record
+length of unformatted files to 2 GB.
+
@end table
@node Code Gen Options
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 111963)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -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;
@@ -2296,6 +2297,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);
@@ -2942,6 +2947,21 @@ gfc_generate_function_code (gfc_namespac
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)
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c (revision 111963)
+++ gcc/fortran/options.c (working copy)
@@ -594,6 +594,17 @@ gfc_handle_option (size_t scode, const c
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:
+
+ /* An eight-byte record marker is the default. Set to zero,
+ as if no option had been set. */
+ gfc_option.record_marker = 0;
+ break;
}
return result;
Index: libgfortran/runtime/compile_options.c
===================================================================
--- libgfortran/runtime/compile_options.c (revision 111963)
+++ libgfortran/runtime/compile_options.c (working copy)
@@ -74,3 +74,15 @@ 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)
+{
+ if (val != 4)
+ runtime_error ("Invalid value for record marker");
+
+ compile_options.record_marker = val;
+}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 111963)
+++ libgfortran/libgfortran.h (working copy)
@@ -338,6 +338,7 @@ typedef struct
int allow_std;
int pedantic;
int convert;
+ int record_marker;
}
compile_options_t;
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (revision 111963)
+++ libgfortran/io/file_pos.c (working copy)
@@ -104,21 +104,43 @@ static void
unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset m, new;
- int length;
+ GFC_INTEGER_4 m4;
+ int length, length_read;
char *p;
- length = sizeof (gfc_offset);
+ if (compile_options.record_marker == 4)
+ length = sizeof (GFC_INTEGER_4);
+ else
+ length = sizeof (gfc_offset);
+
+ length_read = length;
- p = salloc_r_at (u->s, &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));
+ {
+ if (length == 4)
+ {
+ memcpy (&m4, p, sizeof (m4));
+ m = m4;
+ }
+ else
+ memcpy (&m, p, sizeof (gfc_offset));
+ }
else
- reverse_memcpy (&m, p, sizeof (gfc_offset));
+ {
+ if (length == 4)
+ {
+ reverse_memcpy (&m4, p, sizeof (m4));
+ m = m4;
+ }
+ else
+ reverse_memcpy (&m, p, sizeof (gfc_offset));
+ }
if ((new = file_position (u->s) - m - 2*length) < 0)
new = 0;
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (revision 111963)
+++ libgfortran/io/open.c (working copy)
@@ -399,7 +399,12 @@ new_unit (st_parameter_open *opp, gfc_un
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
u->recl = opp->recl_in;
else
- u->recl = max_offset;
+ {
+ if (compile_options.record_marker == 4)
+ u->recl = GFC_INTEGER_4_HUGE;
+ else
+ u->recl = max_offset;
+ }
/* If the file is direct access, calculate the maximum record number
via a division now instead of letting the multiplication overflow
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 111963)
+++ libgfortran/io/transfer.c (working copy)
@@ -1226,14 +1226,21 @@ static void
us_read (st_parameter_dt *dtp)
{
char *p;
- int n;
+ int n, n_read;
+ GFC_INTEGER_4 i4;
gfc_offset i;
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
return;
- n = sizeof (gfc_offset);
- p = salloc_r (dtp->u.p.current_unit->s, &n);
+ if (compile_options.record_marker == 4)
+ n = 4;
+ else
+ n = sizeof (gfc_offset);
+
+ n_read = n;
+
+ p = salloc_r (dtp->u.p.current_unit->s, &n_read);
if (n == 0)
{
@@ -1241,7 +1248,7 @@ us_read (st_parameter_dt *dtp)
return; /* end of file */
}
- if (p == NULL || n != sizeof (gfc_offset))
+ if (p == NULL || n_read != n)
{
generate_error (&dtp->common, ERROR_BAD_US, NULL);
return;
@@ -1249,9 +1256,25 @@ 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));
+ {
+ if (n == 4)
+ {
+ memcpy (&i4, p, sizeof (i4));
+ i = i4;
+ }
+ else
+ memcpy (&i, p, sizeof (gfc_offset));
+ }
else
- reverse_memcpy (&i, p, sizeof (gfc_offset));
+ {
+ if (n == 4)
+ {
+ memcpy (&i4, p, sizeof (i4));
+ i = i4;
+ }
+ else
+ reverse_memcpy (&i, p, sizeof (gfc_offset));
+ }
dtp->u.p.current_unit->bytes_left = i;
}
@@ -1267,7 +1290,11 @@ us_write (st_parameter_dt *dtp)
gfc_offset dummy;
dummy = 0;
- nbytes = sizeof (gfc_offset);
+
+ if (compile_options.record_marker == 4)
+ nbytes = sizeof (GFC_INTEGER_4);
+ else
+ nbytes = sizeof (gfc_offset);
if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
generate_error (&dtp->common, ERROR_OS, NULL);
@@ -1670,7 +1697,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 == 4 ?
+ sizeof (GFC_INTEGER_4) : sizeof (gfc_offset);
/* Fall through... */
@@ -1770,20 +1799,48 @@ 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;
+
+ if (compile_options.record_marker == 4)
+ len = sizeof (GFC_INTEGER_4);
+ else
+ len = sizeof (gfc_offset);
+
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
- 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);
- }
+ {
+ if (len == 4)
+ {
+ buf4 = buf;
+ return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+ }
+ else
+ return swrite (dtp->u.p.current_unit->s, &buf, &len);
+ }
+ else
+ {
+ if (len == 4)
+ {
+ GFC_INTEGER_4 p4;
+
+ buf4 = buf;
+ reverse_memcpy (&p4, &buf4, sizeof (GFC_INTEGER_4));
+ return swrite (dtp->u.p.current_unit->s, &p4, &len);
+ }
+ else
+ {
+ gfc_offset p;
+
+ reverse_memcpy (&p, &buf, sizeof (gfc_offset));
+ return swrite (dtp->u.p.current_unit->s, &p, &len);
+ }
+ }
}
@@ -1795,6 +1852,7 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -1827,11 +1885,16 @@ next_record_w (st_parameter_dt *dtp, int
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))
- == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
+ == FAILURE)
goto io_error;
if (write_us_marker (dtp, m) != 0)
@@ -1839,7 +1902,7 @@ next_record_w (st_parameter_dt *dtp, int
/* 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;
-------------- next part --------------
! { dg-do run }
! { dg-options "-frecord-marker=4" }
program main
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
-------------- next part --------------
! { 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
write (*,*) ' '
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
More information about the Fortran
mailing list