diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 17 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/invoke.texi | 18 | ||||
| -rw-r--r-- | gcc/fortran/lang.opt | 4 | ||||
| -rw-r--r-- | gcc/fortran/options.c | 9 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 17 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/convert_implied_open.f90 | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unf_short_record_1.f90 | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unformatted_subrecord_1.f90 | 45 | ||||
| -rw-r--r-- | libgfortran/ChangeLog | 43 | ||||
| -rw-r--r-- | libgfortran/io/file_pos.c | 108 | ||||
| -rw-r--r-- | libgfortran/io/io.h | 19 | ||||
| -rw-r--r-- | libgfortran/io/open.c | 38 | ||||
| -rw-r--r-- | libgfortran/io/transfer.c | 552 | ||||
| -rw-r--r-- | libgfortran/libgfortran.h | 2 | ||||
| -rw-r--r-- | libgfortran/runtime/compile_options.c | 20 | ||||
| -rw-r--r-- | libgfortran/runtime/error.c | 2 |
18 files changed, 665 insertions, 253 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9442f68..be3e91e 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 277cc78..9a18e7851 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 c27218c..c4ee5d3 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 053f63b..ebd6b8d 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 f03319b..6ec8467 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 1f3ab7d..270083f 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 08b4e04..fe29e86 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 4066f61..9c25b5d 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 1bb6273..45c94c2 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 0000000..5812a8e --- /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 97e7f3a..ca82392 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 979dec5..df722e4 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 e8e8390..4d227dd 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 9b4f0cd..06fba75 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 329d498..4270d61 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 ff94765..644a0ad 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 fb6ac50..b2aef05 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 3f03f03..122f6d1 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: |