From bbaaa7b1b75800e7d846f34dc9f7bcd04ae6ded9 Mon Sep 17 00:00:00 2001
From: tkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 1 Dec 2006 21:04:38 +0000
Subject: [PATCH] 2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/29568
* gfortran.dg/convert_implied_open.f90: Change to
new default record length.
* gfortran.dg/unf_short_record_1.f90: Adapt to
new error message.
* gfortran.dg/unformatted_subrecords_1.f90: New test.
2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/29568
* gfortran.h (gfc_option_t): Add max_subrecord_length.
(top level): Define MAX_SUBRECORD_LENGTH.
* lang.opt: Add option -fmax-subrecord-length=.
* trans-decl.c: Add new function set_max_subrecord_length.
(gfc_generate_function_code): If we are within the main
program and max_subrecord_length has been set, call
set_max_subrecord_length.
* options.c (gfc_init_options): Add defaults for
max_subrecord_lenght, convert and record_marker.
(gfc_handle_option): Add handling for
-fmax_subrecord_length.
* invoke.texi: Document the new default for
-frecord-marker=<n>.
2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/29568
* libgfortran/libgfortran.h (compile_options_t): Add
record_marker. (top level): Define GFC_MAX_SUBRECORD_LENGTH.
* runtime/compile_options.c (set_record_marker): Change
default to four-byte record marker.
(set_max_subrecord_length): New function.
* runtime/error.c (translate_error): Change error message
for short record on unformatted read.
* io/io.h (gfc_unit): Add recl_subrecord, bytes_left_subrecord
and continued.
* io/file_pos.c (unformatted_backspace): Change default of record
marker size to four bytes. Loop over subrecords.
* io/open.c: Default recl is max_offset. If
compile_options.max_subrecord_length has been set, set set
u->recl_subrecord to its value, to the maximum value otherwise.
* io/transfer.c (top level): Add prototypes for us_read, us_write,
next_record_r_unf and next_record_w_unf.
(read_block_direct): Separate codepaths for unformatted direct
and unformatted sequential. If a recl has been set by the
user, use the number of bytes left for the record if it is smaller
than the read request. Loop over subrecords. Set an error if the
user has set a recl and the read was short.
(write_buf): Separate codepaths for unformatted direct and
unformatted sequential. If a recl has been set by the
user, use the number of bytes left for the record if it is smaller
than the read request. Loop over subrecords. Set an error if the
user has set a recl and the read was short.
(us_read): Add parameter continued (to indicate that bytes_left
should not be intialized). Change default of record marker size
to four bytes. Use subrecord. If the subrecord length is smaller than
zero, this indicates a continuation.
(us_write): Add parameter continued (to indicate that the continued
flag should be set). Use subrecord.
(pre_position): Use 0 for continued on us_write and us_read calls.
(skip_record): New function.
(next_record_r_unf): New function.
(next_record_r): Use next_record_r_unf.
(write_us_marker): Default size for record markers is four bytes.
(next_record_w_unf): New function.
(next_record_w): Use next_record_w_unf.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@119412 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/fortran/ChangeLog | 17 +
gcc/fortran/gfortran.h | 5 +-
gcc/fortran/invoke.texi | 18 +-
gcc/fortran/lang.opt | 4 +
gcc/fortran/options.c | 9 +
gcc/fortran/trans-decl.c | 17 +
gcc/testsuite/ChangeLog | 9 +
.../gfortran.dg/convert_implied_open.f90 | 8 +-
.../gfortran.dg/unf_short_record_1.f90 | 2 +-
.../gfortran.dg/unformatted_subrecord_1.f90 | 45 ++
libgfortran/ChangeLog | 43 ++
libgfortran/io/file_pos.c | 108 ++--
libgfortran/io/io.h | 19 +-
libgfortran/io/open.c | 38 +-
libgfortran/io/transfer.c | 552 +++++++++++++-----
libgfortran/libgfortran.h | 2 +
libgfortran/runtime/compile_options.c | 20 +-
libgfortran/runtime/error.c | 2 +-
18 files changed, 665 insertions(+), 253 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/unformatted_subrecord_1.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9442f687e8d9..be3e91e5dacb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
+
+ PR libfortran/29568
+ * gfortran.h (gfc_option_t): Add max_subrecord_length.
+ (top level): Define MAX_SUBRECORD_LENGTH.
+ * lang.opt: Add option -fmax-subrecord-length=.
+ * trans-decl.c: Add new function set_max_subrecord_length.
+ (gfc_generate_function_code): If we are within the main
+ program and max_subrecord_length has been set, call
+ set_max_subrecord_length.
+ * options.c (gfc_init_options): Add defaults for
+ max_subrecord_lenght, convert and record_marker.
+ (gfc_handle_option): Add handling for
+ -fmax_subrecord_length.
+ * invoke.texi: Document the new default for
+ -frecord-marker=<n>.
+
2006-11-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29976
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 277cc7836a09..9a18e7851d72 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -59,6 +59,9 @@ char *alloca ();
#define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */
+#define MAX_SUBRECORD_LENGTH 2147483639 /* 2**31-9 */
+
+
#define free(x) Use_gfc_free_instead_of_free()
#define gfc_is_whitespace(c) ((c==' ') || (c=='\t'))
@@ -1661,12 +1664,12 @@ typedef struct
int fshort_enums;
int convert;
int record_marker;
+ int max_subrecord_length;
}
gfc_option_t;
extern gfc_option_t gfc_option;
-
/* Constructor nodes for array and structure constructors. */
typedef struct gfc_constructor
{
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index c27218c4444c..c4ee5d351baa 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -650,13 +650,17 @@ 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.
-
+Valid values for @var{length} are 4 and 8. Default is 4.
+@emph{This is different from previous versions of gfortran},
+which specified a default record marker length of 8 on most
+systems. If you want to read or write files compatible
+with earlier versions of gfortran, use @samp{-frecord-marker=8}.
+
+@cindex -fmax-subrecord-length=@var{length}
+@item -fmax-subrecord-length=@var{length}
+Specify the maximum length for a subrecord. The maximum permitted
+value for length is 2147483639, which is also the default. Only
+really useful for use by the gfortran testsuite.
@end table
@node Code Gen Options
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 053f63b00191..ebd6b8dd8ec0 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -189,6 +189,10 @@ fmax-identifier-length=
Fortran RejectNegative Joined UInteger
-fmax-identifier-length=<n> Maximum identifier length
+fmax-subrecord-length=
+Fortran RejectNegative Joined UInteger
+-fmax-subrecord-length=<n> Maximum length for subrecords
+
fmax-stack-var-size=
Fortran RejectNegative Joined UInteger
-fmax-stack-var-size=<n> Size in bytes of the largest array that will be put on the stack
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index f03319bbcea6..6ec846761850 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -51,6 +51,9 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.max_continue_fixed = 19;
gfc_option.max_continue_free = 39;
gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN;
+ gfc_option.max_subrecord_length = 0;
+ gfc_option.convert = CONVERT_NATIVE;
+ gfc_option.record_marker = 0;
gfc_option.verbose = 0;
gfc_option.warn_aliasing = 0;
@@ -636,6 +639,12 @@ gfc_handle_option (size_t scode, const char *arg, int value)
case OPT_frecord_marker_8:
gfc_option.record_marker = 8;
break;
+
+ case OPT_fmax_subrecord_length_:
+ if (value > MAX_SUBRECORD_LENGTH)
+ gfc_fatal_error ("Maximum subrecord length cannot exceed %d", MAX_SUBRECORD_LENGTH);
+
+ gfc_option.max_subrecord_length = value;
}
return result;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 1f3ab7d42f6d..270083f022e1 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -94,6 +94,7 @@ tree gfor_fndecl_set_fpe;
tree gfor_fndecl_set_std;
tree gfor_fndecl_set_convert;
tree gfor_fndecl_set_record_marker;
+tree gfor_fndecl_set_max_subrecord_length;
tree gfor_fndecl_ctime;
tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
@@ -2379,6 +2380,10 @@ gfc_build_builtin_function_decls (void)
gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
void_type_node, 1, gfc_c_int_type_node);
+ gfor_fndecl_set_max_subrecord_length =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
+ 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);
@@ -3187,6 +3192,18 @@ gfc_generate_function_code (gfc_namespace * ns)
}
+ if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 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.max_subrecord_length));
+ tmp = build_function_call_expr (gfor_fndecl_set_max_subrecord_length, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
&& sym->attr.subroutine)
{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 08b4e0446e56..fe29e8615eb6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
+
+ PR libfortran/29568
+ * gfortran.dg/convert_implied_open.f90: Change to
+ new default record length.
+ * gfortran.dg/unf_short_record_1.f90: Adapt to
+ new error message.
+ * gfortran.dg/unformatted_subrecords_1.f90: New test.
+
2006-12-01 Andrew MacLeod <amacleod@redhat.com>
* gcc.dg/max-1.c: Remove reference to -fno-tree-lrs option.
diff --git a/gcc/testsuite/gfortran.dg/convert_implied_open.f90 b/gcc/testsuite/gfortran.dg/convert_implied_open.f90
index 4066f618cc22..9c25b5d961c2 100644
--- a/gcc/testsuite/gfortran.dg/convert_implied_open.f90
+++ b/gcc/testsuite/gfortran.dg/convert_implied_open.f90
@@ -3,13 +3,13 @@
! PR 26735 - implied open didn't use to honor -fconvert
program main
implicit none
- integer (kind=8) :: i1, i2, i3
- write (10) 1_8
+ integer (kind=4) :: i1, i2, i3
+ write (10) 1_4
close (10)
- open (10, form="unformatted", access="direct", recl=8)
+ open (10, form="unformatted", access="direct", recl=4)
read (10,rec=1) i1
read (10,rec=2) i2
read (10,rec=3) i3
- if (i1 /= 8 .or. i2 /= 1 .or. i3 /= 8) call abort
+ if (i1 /= 4 .or. i2 /= 1 .or. i3 /= 4) call abort
close (10,status="delete")
end program main
diff --git a/gcc/testsuite/gfortran.dg/unf_short_record_1.f90 b/gcc/testsuite/gfortran.dg/unf_short_record_1.f90
index 1bb62736a361..45c94c29405d 100644
--- a/gcc/testsuite/gfortran.dg/unf_short_record_1.f90
+++ b/gcc/testsuite/gfortran.dg/unf_short_record_1.f90
@@ -11,7 +11,7 @@ program main
read (10, err=20, iomsg=msg) a
call abort
20 continue
- if (msg .ne. "Short record on unformatted read") call abort
+ if (msg .ne. "I/O past end of record on unformatted file") call abort
if (a(1) .ne. 'a' .or. a(2) .ne. 'b' .or. a(3) .ne. 'b') call abort
close (10, status="delete")
end program main
diff --git a/gcc/testsuite/gfortran.dg/unformatted_subrecord_1.f90 b/gcc/testsuite/gfortran.dg/unformatted_subrecord_1.f90
new file mode 100644
index 000000000000..5812a8eaaf56
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unformatted_subrecord_1.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { dg-options "-fmax-subrecord-length=16" }
+! Test Intel record markers with 16-byte subrecord sizes.
+program main
+ implicit none
+ integer, dimension(20) :: n
+ integer, dimension(30) :: m
+ integer :: i
+ real :: r
+ integer :: k
+ ! Maximum subrecord length is 16 here, or the test will fail.
+ open (10, file="f10.dat", &
+ form="unformatted", access="sequential")
+ n = (/ (i**2, i=1, 20) /)
+ write (10) n
+ close (10)
+ ! Read back the file, including record markers.
+ open (10, file="f10.dat", form="unformatted", access="stream")
+ read (10) m
+ if (any(m .ne. (/ -16, 1, 4, 9, 16, 16, -16, 25, 36, 49, 64, &
+ -16, -16, 81, 100, 121, 144, -16, -16, 169, 196, 225, &
+ 256, -16, 16, 289, 324, 361, 400, -16 /))) call abort
+ close (10)
+ open (10, file="f10.dat", form="unformatted", &
+ access="sequential")
+ m = 42
+ read (10) m(1:5)
+ if (any(m(1:5) .ne. (/ 1, 4, 9, 16, 25 /))) call abort
+ if (any(m(6:30) .ne. 42)) call abort
+ backspace 10
+ n = 0
+ read (10) n(1:5)
+ if (any(n(1:5) .ne. (/ 1, 4, 9, 16, 25 /))) call abort
+ if (any(n(6:20) .ne. 0)) call abort
+ ! Append to the end of the file
+ write (10) 3.14
+ ! Test multiple backspace statements
+ backspace 10
+ backspace 10
+ read (10) k
+ if (k .ne. 1) call abort
+ read (10) r
+ if (abs(r-3.14) .gt. 1e-7) call abort
+ close (10, status="delete")
+end program main
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 97e7f3a2c2bd..ca823924d0b0 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,46 @@
+2006-12-01 Thomas Koenig <Thomas.Koenig@online.de>
+
+ PR libfortran/29568
+ * libgfortran/libgfortran.h (compile_options_t): Add
+ record_marker. (top level): Define GFC_MAX_SUBRECORD_LENGTH.
+ * runtime/compile_options.c (set_record_marker): Change
+ default to four-byte record marker.
+ (set_max_subrecord_length): New function.
+ * runtime/error.c (translate_error): Change error message
+ for short record on unformatted read.
+ * io/io.h (gfc_unit): Add recl_subrecord, bytes_left_subrecord
+ and continued.
+ * io/file_pos.c (unformatted_backspace): Change default of record
+ marker size to four bytes. Loop over subrecords.
+ * io/open.c: Default recl is max_offset. If
+ compile_options.max_subrecord_length has been set, set set
+ u->recl_subrecord to its value, to the maximum value otherwise.
+ * io/transfer.c (top level): Add prototypes for us_read, us_write,
+ next_record_r_unf and next_record_w_unf.
+ (read_block_direct): Separate codepaths for unformatted direct
+ and unformatted sequential. If a recl has been set by the
+ user, use the number of bytes left for the record if it is smaller
+ than the read request. Loop over subrecords. Set an error if the
+ user has set a recl and the read was short.
+ (write_buf): Separate codepaths for unformatted direct and
+ unformatted sequential. If a recl has been set by the
+ user, use the number of bytes left for the record if it is smaller
+ than the read request. Loop over subrecords. Set an error if the
+ user has set a recl and the read was short.
+ (us_read): Add parameter continued (to indicate that bytes_left
+ should not be intialized). Change default of record marker size
+ to four bytes. Use subrecord. If the subrecord length is smaller than
+ zero, this indicates a continuation.
+ (us_write): Add parameter continued (to indicate that the continued
+ flag should be set). Use subrecord.
+ (pre_position): Use 0 for continued on us_write and us_read calls.
+ (skip_record): New function.
+ (next_record_r_unf): New function.
+ (next_record_r): Use next_record_r_unf.
+ (write_us_marker): Default size for record markers is four bytes.
+ (next_record_w_unf): New function.
+ (next_record_w): Use next_record_w_unf.
+
2006-11-25 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* Makefile.am: Remove intrinsics/erf.c and intrinsics/bessel.c.
diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c
index 979dec55513b..df722e4cbc79 100644
--- a/libgfortran/io/file_pos.c
+++ b/libgfortran/io/file_pos.c
@@ -98,7 +98,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
sequential file. We are guaranteed to be between records on entry and
- we have to shift to the previous record. */
+ we have to shift to the previous record. Loop over subrecords. */
static void
unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
@@ -107,74 +107,74 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
GFC_INTEGER_4 m4;
GFC_INTEGER_8 m8;
int length, length_read;
+ int continued;
char *p;
if (compile_options.record_marker == 0)
- length = sizeof (gfc_offset);
+ length = sizeof (GFC_INTEGER_4);
else
length = compile_options.record_marker;
- length_read = length;
+ do
+ {
+ length_read = length;
- p = salloc_r_at (u->s, &length_read,
- file_position (u->s) - length);
- if (p == NULL || length_read != length)
- goto io_error;
+ p = salloc_r_at (u->s, &length_read,
+ file_position (u->s) - length);
+ if (p == NULL || length_read != length)
+ goto io_error;
- /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
- if (u->flags.convert == CONVERT_NATIVE)
- {
- switch (compile_options.record_marker)
+ /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
+ if (u->flags.convert == CONVERT_NATIVE)
{
- 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;
+ switch (length)
+ {
+ 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
- {
- switch (compile_options.record_marker)
+ else
{
- 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;
+ switch (length)
+ {
+ 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;
+ }
+
}
- }
+ continued = m < 0;
+ if (continued)
+ m = -m;
- if ((new = file_position (u->s) - m - 2*length) < 0)
- new = 0;
+ if ((new = file_position (u->s) - m - 2*length) < 0)
+ new = 0;
- if (sseek (u->s, new) == FAILURE)
- goto io_error;
+ if (sseek (u->s, new) == FAILURE)
+ goto io_error;
+ } while (continued);
u->last_record--;
return;
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index e8e8390d1c54..4d227dd3b8c8 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -499,12 +499,19 @@ typedef struct gfc_unit
unit_mode mode;
unit_flags flags;
- /* recl -- Record length of the file.
- last_record -- Last record number read or written
- maxrec -- Maximum record number in a direct access file
- bytes_left -- Bytes left in current record.
- strm_pos -- Current position in file for STREAM I/O. */
- gfc_offset recl, last_record, maxrec, bytes_left, strm_pos;
+ /* recl -- Record length of the file.
+ last_record -- Last record number read or written
+ maxrec -- Maximum record number in a direct access file
+ bytes_left -- Bytes left in current record.
+ strm_pos -- Current position in file for STREAM I/O.
+ recl_subrecord -- Maximum length for subrecord.
+ bytes_left_subrecord -- Bytes left in current subrecord. */
+ gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
+ recl_subrecord, bytes_left_subrecord;
+
+ /* Set to 1 if we have read a subrecord. */
+
+ int continued;
__gthread_mutex_t lock;
/* Number of threads waiting to acquire this unit's lock.
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
index 9b4f0cd7122d..06fba75e1df0 100644
--- a/libgfortran/io/open.c
+++ b/libgfortran/io/open.c
@@ -413,23 +413,29 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
else
{
u->flags.has_recl = 0;
- switch (compile_options.record_marker)
+ u->recl = max_offset;
+ if (compile_options.max_subrecord_length)
{
- 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;
+ u->recl_subrecord = compile_options.max_subrecord_length;
+ }
+ else
+ {
+ switch (compile_options.record_marker)
+ {
+ case 0:
+ /* Fall through */
+ case sizeof (GFC_INTEGER_4):
+ u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
+ break;
+
+ case sizeof (GFC_INTEGER_8):
+ u->recl_subrecord = max_offset - 16;
+ break;
+
+ default:
+ runtime_error ("Illegal value for record marker");
+ break;
+ }
}
}
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 329d49828d4e..4270d61e693c 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -82,6 +82,11 @@ extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array);
+static void us_read (st_parameter_dt *, int);
+static void us_write (st_parameter_dt *, int);
+static void next_record_r_unf (st_parameter_dt *, int);
+static void next_record_w_unf (st_parameter_dt *, int);
+
static const st_option advance_opt[] = {
{"yes", ADVANCE_YES},
{"no", ADVANCE_NO},
@@ -336,12 +341,16 @@ read_block (st_parameter_dt *dtp, int *length)
}
-/* Reads a block directly into application data space. */
+/* Reads a block directly into application data space. This is for
+ unformatted files. */
static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
- size_t nread;
+ size_t to_read_record;
+ size_t have_read_record;
+ size_t to_read_subrecord;
+ size_t have_read_subrecord;
int short_record;
if (is_stream_io (dtp))
@@ -353,62 +362,169 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
return;
}
- nread = *nbytes;
- if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
+ to_read_record = *nbytes;
+ have_read_record = to_read_record;
+ if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
-
- if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
- generate_error (&dtp->common, ERROR_END, NULL);
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
+ if (to_read_record != have_read_record)
+ {
+ /* Short read, e.g. if we hit EOF. */
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
return;
}
- /* Unformatted file with records */
- if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- short_record = 1;
- nread = (size_t) dtp->u.p.current_unit->bytes_left;
- *nbytes = nread;
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+ {
+ short_record = 1;
+ to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+ *nbytes = to_read_record;
- if (dtp->u.p.current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
+ }
+
+ else
+ {
+ short_record = 0;
+ to_read_record = *nbytes;
+ }
+
+ dtp->u.p.current_unit->bytes_left -= to_read_record;
+
+ if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return;
+ }
+
+ if (to_read_record != *nbytes) /* Short read, e.g. if we hit EOF. */
{
- dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ *nbytes = to_read_record;
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
+
+ if (short_record)
+ {
+ generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+ return;
+ }
+ return;
}
+ /* Unformatted sequential. We loop over the subrecords, reading
+ until the request has been fulfilled or the record has run out
+ of continuation subrecords. */
+
+ /* Check whether we exceed the total record length. */
+
+ if (dtp->u.p.current_unit->flags.has_recl)
+ {
+ to_read_record =
+ *nbytes > (size_t) dtp->u.p.current_unit->bytes_left ?
+ *nbytes : (size_t) dtp->u.p.current_unit->bytes_left;
+ short_record = 1;
+ }
else
{
+ to_read_record = *nbytes;
short_record = 0;
- nread = *nbytes;
}
+ have_read_record = 0;
- dtp->u.p.current_unit->bytes_left -= nread;
-
- if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
+ while(1)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return;
- }
+ if (dtp->u.p.current_unit->bytes_left_subrecord
+ < (gfc_offset) to_read_record)
+ {
+ to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
+ to_read_record -= to_read_subrecord;
- if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
- {
- *nbytes = nread;
- generate_error (&dtp->common, ERROR_END, NULL);
- return;
+ if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
+ {
+ if (dtp->u.p.current_unit->continued)
+ {
+ /* Skip to the next subrecord */
+ next_record_r_unf (dtp, 0);
+ us_read (dtp, 1);
+ continue;
+ }
+ else
+ {
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
+ }
+ }
+
+ else
+ {
+ to_read_subrecord = to_read_record;
+ to_read_record = 0;
+ }
+
+ dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
+
+ have_read_subrecord = to_read_subrecord;
+ if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
+ &have_read_subrecord) != 0)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return;
+ }
+
+ have_read_record += have_read_subrecord;
+
+ if (to_read_subrecord != have_read_subrecord) /* Short read,
+ e.g. if we hit EOF. */
+ {
+ *nbytes = have_read_record;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
+
+ if (to_read_record > 0)
+ {
+ if (dtp->u.p.current_unit->continued)
+ {
+ next_record_r_unf (dtp, 0);
+ us_read (dtp, 1);
+ }
+ else
+ {
+ generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+ return;
+ }
+ }
+ else
+ {
+ /* Normal exit, the read request has been fulfilled. */
+ break;
+ }
}
+ dtp->u.p.current_unit->bytes_left -= have_read_record;
if (short_record)
{
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
return;
}
+ return;
}
@@ -471,11 +587,20 @@ write_block (st_parameter_dt *dtp, int length)
}
-/* High level interface to swrite(), taking care of errors. */
+/* High level interface to swrite(), taking care of errors. This is only
+ called for unformatted files. There are three cases to consider:
+ Stream I/O, unformatted direct, unformatted sequential. */
static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
+
+ size_t have_written, to_write_subrecord;
+ int short_record;
+
+
+ /* Stream I/O. */
+
if (is_stream_io (dtp))
{
if (sseek (dtp->u.p.current_unit->s,
@@ -484,42 +609,88 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
generate_error (&dtp->common, ERROR_OS, NULL);
return FAILURE;
}
+
+ if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return FAILURE;
+ }
+
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
+
+ return SUCCESS;
}
- else
+
+ /* Unformatted direct access. */
+
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
{
- /* For preconnected units with default record length, set
- bytes left to unit record length and proceed, otherwise
- error. */
- if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
- || dtp->u.p.current_unit->unit_number == options.stderr_unit)
- && dtp->u.p.current_unit->recl == DEFAULT_RECL)
- dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
- else
- {
- if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
- generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
- else
- generate_error (&dtp->common, ERROR_EOR, NULL);
- return FAILURE;
- }
+ generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
+ return FAILURE;
+ }
+
+ if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return FAILURE;
}
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
+
+ return SUCCESS;
+
}
- if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ /* Unformatted sequential. */
+
+ have_written = 0;
+
+ if (dtp->u.p.current_unit->flags.has_recl
+ && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return FAILURE;
+ nbytes = dtp->u.p.current_unit->bytes_left;
+ short_record = 1;
+ }
+ else
+ {
+ short_record = 0;
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (gfc_offset) nbytes;
+ while (1)
+ {
+
+ to_write_subrecord =
+ (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
+ (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
+
+ dtp->u.p.current_unit->bytes_left_subrecord -=
+ (gfc_offset) to_write_subrecord;
- dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
+ if (swrite (dtp->u.p.current_unit->s, buf + have_written,
+ &to_write_subrecord) != 0)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return FAILURE;
+ }
+
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
+ nbytes -= to_write_subrecord;
+ have_written += to_write_subrecord;
+ if (nbytes == 0)
+ break;
+
+ next_record_w_unf (dtp, 1);
+ us_write (dtp, 1);
+ }
+ dtp->u.p.current_unit->bytes_left -= have_written;
+ if (short_record)
+ {
+ generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
+ return FAILURE;
+ }
return SUCCESS;
}
@@ -1357,7 +1528,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
/* Preposition a sequential unformatted file while reading. */
static void
-us_read (st_parameter_dt *dtp)
+us_read (st_parameter_dt *dtp, int continued)
{
char *p;
int n;
@@ -1370,7 +1541,7 @@ us_read (st_parameter_dt *dtp)
return;
if (compile_options.record_marker == 0)
- n = sizeof (gfc_offset);
+ n = sizeof (GFC_INTEGER_4);
else
n = compile_options.record_marker;
@@ -1393,12 +1564,8 @@ 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)
{
- switch (compile_options.record_marker)
+ switch (nr)
{
- case 0:
- memcpy (&i, p, sizeof(gfc_offset));
- break;
-
case sizeof(GFC_INTEGER_4):
memcpy (&i4, p, sizeof (i4));
i = i4;
@@ -1415,12 +1582,8 @@ us_read (st_parameter_dt *dtp)
}
}
else
- switch (compile_options.record_marker)
+ switch (nr)
{
- case 0:
- reverse_memcpy (&i, p, sizeof(gfc_offset));
- break;
-
case sizeof(GFC_INTEGER_4):
reverse_memcpy (&i4, p, sizeof (i4));
i = i4;
@@ -1436,7 +1599,19 @@ us_read (st_parameter_dt *dtp)
break;
}
- dtp->u.p.current_unit->bytes_left = i;
+ if (i >= 0)
+ {
+ dtp->u.p.current_unit->bytes_left_subrecord = i;
+ dtp->u.p.current_unit->continued = 0;
+ }
+ else
+ {
+ dtp->u.p.current_unit->bytes_left_subrecord = -i;
+ dtp->u.p.current_unit->continued = 1;
+ }
+
+ if (! continued)
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
@@ -1444,7 +1619,7 @@ us_read (st_parameter_dt *dtp)
amount to writing a bogus length that will be filled in later. */
static void
-us_write (st_parameter_dt *dtp)
+us_write (st_parameter_dt *dtp, int continued)
{
size_t nbytes;
gfc_offset dummy;
@@ -1452,7 +1627,7 @@ us_write (st_parameter_dt *dtp)
dummy = 0;
if (compile_options.record_marker == 0)
- nbytes = sizeof (gfc_offset);
+ nbytes = sizeof (GFC_INTEGER_4);
else
nbytes = compile_options.record_marker ;
@@ -1460,12 +1635,12 @@ us_write (st_parameter_dt *dtp)
generate_error (&dtp->common, ERROR_OS, NULL);
/* For sequential unformatted, if RECL= was not specified in the OPEN
- we write until we have more bytes than can fit in the record markers.
- If disk space runs out first, it will error on the write. */
- if (dtp->u.p.current_unit->flags.has_recl == 0)
- dtp->u.p.current_unit->recl = max_offset;
+ we write until we have more bytes than can fit in the subrecord
+ markers, then we write a new subrecord. */
- dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ dtp->u.p.current_unit->bytes_left_subrecord =
+ dtp->u.p.current_unit->recl_subrecord;
+ dtp->u.p.current_unit->continued = continued;
}
@@ -1491,9 +1666,9 @@ pre_position (st_parameter_dt *dtp)
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
- us_read (dtp);
+ us_read (dtp, 0);
else
- us_write (dtp);
+ us_write (dtp, 0);
break;
@@ -1886,17 +2061,92 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
return index;
}
-/* Space to the next record for read mode. If the file is not
- seekable, we read MAX_READ chunks until we get to the right
+
+
+/* Skip to the end of the current record, taking care of an optional
+ record marker of size bytes. If the file is not seekable, we
+ read chunks of size MAX_READ until we get to the right
position. */
#define MAX_READ 4096
+static void
+skip_record (st_parameter_dt *dtp, size_t bytes)
+{
+ gfc_offset new;
+ int rlength, length;
+ char *p;
+
+ dtp->u.p.current_unit->bytes_left_subrecord += bytes;
+ if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
+ return;
+
+ if (is_seekable (dtp->u.p.current_unit->s))
+ {
+ new = file_position (dtp->u.p.current_unit->s)
+ + dtp->u.p.current_unit->bytes_left_subrecord;
+
+ /* Direct access files do not generate END conditions,
+ only I/O errors. */
+ if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ }
+ else
+ { /* Seek by reading data. */
+ while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
+ {
+ rlength = length =
+ (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
+ MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
+
+ p = salloc_r (dtp->u.p.current_unit->s, &rlength);
+ if (p == NULL)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return;
+ }
+
+ dtp->u.p.current_unit->bytes_left_subrecord -= length;
+ }
+ }
+
+}
+
+#undef MAX_READ
+
+/* Advance to the next record reading unformatted files, taking
+ care of subrecords. If complete_record is nonzero, we loop
+ until all subrecords are cleared. */
+
+static void
+next_record_r_unf (st_parameter_dt *dtp, int complete_record)
+{
+ size_t bytes;
+
+ bytes = compile_options.record_marker == 0 ?
+ sizeof (GFC_INTEGER_4) : compile_options.record_marker;
+
+ while(1)
+ {
+
+ /* Skip over tail */
+
+ skip_record (dtp, bytes);
+
+ if ( ! (complete_record && dtp->u.p.current_unit->continued))
+ return;
+
+ us_read (dtp, 1);
+ }
+}
+
+/* Space to the next record for read mode. */
+
static void
next_record_r (st_parameter_dt *dtp)
{
- gfc_offset new, record;
- int bytes_left, rlength, length;
+ gfc_offset record;
+ int length, bytes_left;
char *p;
switch (current_mode (dtp))
@@ -1906,47 +2156,12 @@ next_record_r (st_parameter_dt *dtp)
return;
case UNFORMATTED_SEQUENTIAL:
-
- /* Skip over tail */
- dtp->u.p.current_unit->bytes_left +=
- compile_options.record_marker == 0 ?
- sizeof (gfc_offset) : compile_options.record_marker;
-
- /* Fall through... */
+ next_record_r_unf (dtp, 1);
+ break;
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- if (dtp->u.p.current_unit->bytes_left == 0)
- break;
-
- if (is_seekable (dtp->u.p.current_unit->s))
- {
- new = file_position (dtp->u.p.current_unit->s)
- + dtp->u.p.current_unit->bytes_left;
-
- /* Direct access files do not generate END conditions,
- only I/O errors. */
- if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
- generate_error (&dtp->common, ERROR_OS, NULL);
-
- }
- else
- { /* Seek by reading data. */
- while (dtp->u.p.current_unit->bytes_left > 0)
- {
- rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
- MAX_READ : dtp->u.p.current_unit->bytes_left;
-
- p = salloc_r (dtp->u.p.current_unit->s, &rlength);
- if (p == NULL)
- {
- generate_error (&dtp->common, ERROR_OS, NULL);
- break;
- }
-
- dtp->u.p.current_unit->bytes_left -= length;
- }
- }
+ skip_record (dtp, 0);
break;
case FORMATTED_STREAM:
@@ -2025,19 +2240,15 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
char p[sizeof (GFC_INTEGER_8)];
if (compile_options.record_marker == 0)
- len = sizeof (gfc_offset);
+ len = sizeof (GFC_INTEGER_4);
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)
+ switch (len)
{
- case 0:
- return swrite (dtp->u.p.current_unit->s, &buf, &len);
- break;
-
case sizeof (GFC_INTEGER_4):
buf4 = buf;
return swrite (dtp->u.p.current_unit->s, &buf4, &len);
@@ -2055,13 +2266,8 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
}
else
{
- switch (compile_options.record_marker)
+ switch (len)
{
- 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));
@@ -2070,7 +2276,7 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
case sizeof (GFC_INTEGER_8):
buf8 = buf;
- reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
+ reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
return swrite (dtp->u.p.current_unit->s, p, &len);
break;
@@ -2082,16 +2288,72 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
}
+/* Position to the next (sub)record in write mode for
+ unformatted sequential files. */
+
+static void
+next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
+{
+ gfc_offset c, m, m_write;
+ size_t record_marker;
+
+ /* Bytes written. */
+ m = dtp->u.p.current_unit->recl_subrecord
+ - dtp->u.p.current_unit->bytes_left_subrecord;
+ c = file_position (dtp->u.p.current_unit->s);
+
+ /* Write the length tail. If we finish a record containing
+ subrecords, we write out the negative length. */
+
+ if (dtp->u.p.current_unit->continued)
+ m_write = -m;
+ else
+ m_write = m;
+
+ if (write_us_marker (dtp, m_write) != 0)
+ goto io_error;
+
+ if (compile_options.record_marker == 0)
+ record_marker = sizeof (GFC_INTEGER_4);
+ else
+ record_marker = compile_options.record_marker;
+
+ /* Seek to the head and overwrite the bogus length with the real
+ length. */
+
+ if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
+ == FAILURE)
+ goto io_error;
+
+ if (next_subrecord)
+ m_write = -m;
+ else
+ m_write = m;
+
+ if (write_us_marker (dtp, m_write) != 0)
+ goto io_error;
+
+ /* Seek past the end of the current record. */
+
+ if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
+ goto io_error;
+
+ return;
+
+ io_error:
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return;
+
+}
/* Position to the next record in write mode. */
static void
next_record_w (st_parameter_dt *dtp, int done)
{
- gfc_offset c, m, record, max_pos;
+ gfc_offset 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;
@@ -2119,35 +2381,7 @@ next_record_w (st_parameter_dt *dtp, int done)
break;
case UNFORMATTED_SEQUENTIAL:
- /* Bytes written. */
- m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
- c = file_position (dtp->u.p.current_unit->s);
-
- /* Write the length tail. */
-
- 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 - record_marker)
- == FAILURE)
- goto io_error;
-
- if (write_us_marker (dtp, m) != 0)
- goto io_error;
-
- /* Seek past the end of the current record. */
-
- if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
- goto io_error;
-
+ next_record_w_unf (dtp, 0);
break;
case FORMATTED_STREAM:
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index ff947655806e..644a0adc7844 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -370,6 +370,7 @@ typedef struct
int pedantic;
int convert;
size_t record_marker;
+ int max_subrecord_length;
}
compile_options_t;
@@ -379,6 +380,7 @@ internal_proto(compile_options);
extern void init_compile_options (void);
internal_proto(init_compile_options);
+#define GFC_MAX_SUBRECORD_LENGTH 2147483639 /* 2**31 - 9 */
/* Structure for statement options. */
diff --git a/libgfortran/runtime/compile_options.c b/libgfortran/runtime/compile_options.c
index fb6ac509f135..b2aef05a832e 100644
--- a/libgfortran/runtime/compile_options.c
+++ b/libgfortran/runtime/compile_options.c
@@ -86,13 +86,11 @@ 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);
+ 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);
+ compile_options.record_marker = sizeof (GFC_INTEGER_8);
break;
default:
@@ -100,3 +98,17 @@ set_record_marker (int val)
break;
}
}
+
+extern void set_max_subrecord_length (int);
+export_proto (set_max_subrecord_length);
+
+void set_max_subrecord_length(int val)
+{
+ if (val > GFC_MAX_SUBRECORD_LENGTH || val < 1)
+ {
+ runtime_error ("Invalid value for maximum subrecord length");
+ return;
+ }
+
+ compile_options.max_subrecord_length = val;
+}
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index 3f03f03f5004..122f6d14bab4 100644
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -437,7 +437,7 @@ translate_error (int code)
break;
case ERROR_SHORT_RECORD:
- p = "Short record on unformatted read";
+ p = "I/O past end of record on unformatted file";
break;
default:
--
GitLab