This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch,fortran] PR25828 F2003 Stream I/O
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Wed, 02 Aug 2006 23:03:41 -0700
- Subject: [patch,fortran] PR25828 F2003 Stream I/O
:ADDPATCH fortran:
The attached patch adds STREAM I/O capability to gfortran. The implementation
uses the dtp->rec variable to keep track of the file position for reads and
writes. This is done to maintain compatibility with current library data
structures. Formatted and unformatted STREAM I/O are handled using existing
lower level functions by adding appropriate condition checks.
Not all INQUIRE functionality is implemented yet and can be added as a separate
patch. INQUIRE(unit=xyzzy, ACCESS=astring) works. "POS=" is not implemented
yet in INQUIRE.
I would like to extend thanks to Janne Blomqvist and Steve Kargl for off-list
reviews.
Current plan is to commit this to 4.3 when approved and then back patch to 4.2.
I think the patch is safe enough for 4.2 now if consensus dictates doing so now.
I would appreciate all the testing that folks can find time for. This has been
tested and regression checked on i686-linux-pc-gnu. Other platforms would be
greatly appreciated.
Those of you who are advanced Fortran gurus, please feel free to try this out.
I am very interested in identifying any corner cases I missed.
Finally, front-end gurus: I would appreciate input on how to INQUIRE dtp->rec
from the st_parameter_dt structure. It is not so obvious to me.
Also included with the patch are several initial test cases.
Ready to commit?
Regards,
Jerry
2006-08-02 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25828
* io.c: Add new IO tag for file position.
(match_dt_element): Match the new tag.
(gfc_resolve_dt): Resolve the new tag.
2006-08-02 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/25828
* io/file_pos.c (st_backspace): Ignore if access=STREAM.
(st_rewind): Handle case of access=STREAM.
* io/open.c (access_opt): Add STREAM_ACCESS.
(edit_modes): Set current_record to zero only if not STREAM.
(new_unit): Initialize maxrec and recl for STREAM.
* io/read.c (read_x): Advance file position for STREAM.
* io/inquire.c (inquire_via_unit): Add text for access = "STREAM".
* io/io.h (enum unit_access): Add ACCESS_STREAM.
Add prototype for is_stream_io () function.
* io/unit.c (is_stream_io): New function to return true if access =
STREAM.
* io/transfer.c (file_mode): Add modes for unformatted stream and
formatted stream. (current_mode): Return appropriate file mode based
on access flags.
(read_block): Handle formatted stream reads.
(read_block_direct): Handle unformatted stream reads.
(write_block): Handle formatted stream writes.
(write_buf): Handle unformatted stream writes.
(pre_position): Position file for STREAM access.
(data_transfer_init): Initialize for stream access, skip irrelevent
error checks.
(next_record_r),(next_record_w), and (next_record): Do nothing for
stream I/O.
(finalize_transfer): Flush when all done if stream I/O.
Index: gcc/fortran/io.c
===================================================================
*** gcc/fortran/io.c (revision 115887)
--- gcc/fortran/io.c (working copy)
*************** static const io_tag
*** 52,57 ****
--- 52,58 ----
tag_unit = {"UNIT", " unit = %e", BT_INTEGER},
tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER},
tag_rec = {"REC", " rec = %e", BT_INTEGER},
+ tag_spos = {"POSITION", " pos = %e", BT_INTEGER},
tag_format = {"FORMAT", NULL, BT_CHARACTER},
tag_iomsg = {"IOMSG", " iomsg = %e", BT_CHARACTER},
tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER},
*************** match_dt_element (io_kind k, gfc_dt * dt
*** 1784,1789 ****
--- 1785,1793 ----
m = match_etag (&tag_rec, &dt->rec);
if (m != MATCH_NO)
return m;
+ m = match_etag (&tag_spos, &dt->rec);
+ if (m != MATCH_NO)
+ return m;
m = match_out_tag (&tag_iomsg, &dt->iomsg);
if (m != MATCH_NO)
return m;
*************** gfc_resolve_dt (gfc_dt * dt)
*** 1855,1860 ****
--- 1859,1865 ----
RESOLVE_TAG (&tag_format, dt->format_expr);
RESOLVE_TAG (&tag_rec, dt->rec);
+ RESOLVE_TAG (&tag_spos, dt->rec);
RESOLVE_TAG (&tag_advance, dt->advance);
RESOLVE_TAG (&tag_iomsg, dt->iomsg);
RESOLVE_TAG (&tag_iostat, dt->iostat);
Index: libgfortran/io/file_pos.c
===================================================================
*** libgfortran/io/file_pos.c (revision 115887)
--- libgfortran/io/file_pos.c (working copy)
*************** st_backspace (st_parameter_filepos *fpp)
*** 205,211 ****
sequential I/O and the next direct access transfer repositions the file
anyway. */
! if (u->flags.access == ACCESS_DIRECT)
goto done;
/* Check for special cases involving the ENDFILE record first. */
--- 205,211 ----
sequential I/O and the next direct access transfer repositions the file
anyway. */
! if (u->flags.access == ACCESS_DIRECT || u->flags.access == ACCESS_STREAM)
goto done;
/* Check for special cases involving the ENDFILE record first. */
*************** st_rewind (st_parameter_filepos *fpp)
*** 291,297 ****
u = find_unit (fpp->common.unit);
if (u != NULL)
{
! if (u->flags.access != ACCESS_SEQUENTIAL)
generate_error (&fpp->common, ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
--- 291,297 ----
u = find_unit (fpp->common.unit);
if (u != NULL)
{
! if (u->flags.access == ACCESS_DIRECT)
generate_error (&fpp->common, ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
*************** st_rewind (st_parameter_filepos *fpp)
*** 301,307 ****
file now. Reset to read mode so two consecutive rewind
statements do not delete the file contents. */
flush (u->s);
! if (u->mode == WRITING)
struncate (u->s);
u->mode = READING;
--- 301,307 ----
file now. Reset to read mode so two consecutive rewind
statements do not delete the file contents. */
flush (u->s);
! if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
struncate (u->s);
u->mode = READING;
Index: libgfortran/io/open.c
===================================================================
*** libgfortran/io/open.c (revision 115887)
--- libgfortran/io/open.c (working copy)
*************** static const st_option access_opt[] = {
*** 40,45 ****
--- 40,46 ----
{"sequential", ACCESS_SEQUENTIAL},
{"direct", ACCESS_DIRECT},
{"append", ACCESS_APPEND},
+ {"stream", ACCESS_STREAM},
{NULL, 0}
};
*************** edit_modes (st_parameter_open *opp, gfc_
*** 214,220 ****
if (sseek (u->s, file_length (u->s)) == FAILURE)
goto seek_error;
! u->current_record = 0;
u->endfile = AT_ENDFILE; /* We are at the end. */
break;
--- 215,223 ----
if (sseek (u->s, file_length (u->s)) == FAILURE)
goto seek_error;
! if (flags->access != ACCESS_STREAM)
! u->current_record = 0;
!
u->endfile = AT_ENDFILE; /* We are at the end. */
break;
*************** new_unit (st_parameter_open *opp, gfc_un
*** 432,437 ****
--- 435,446 ----
if (flags->access == ACCESS_DIRECT)
u->maxrec = max_offset / u->recl;
+
+ if (flags->access == ACCESS_STREAM)
+ {
+ u->maxrec = max_offset;
+ u->recl = 1;
+ }
memmove (u->file, opp->file, opp->file_len);
u->file_len = opp->file_len;
Index: libgfortran/io/read.c
===================================================================
*** libgfortran/io/read.c (revision 115887)
--- libgfortran/io/read.c (working copy)
*************** read_f (st_parameter_dt *dtp, const fnod
*** 841,853 ****
void
read_x (st_parameter_dt *dtp, int n)
{
! if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
! && dtp->u.p.current_unit->bytes_left < n)
! n = dtp->u.p.current_unit->bytes_left;
!
! dtp->u.p.sf_read_comma = 0;
! if (n > 0)
! read_sf (dtp, &n, 1);
! dtp->u.p.sf_read_comma = 1;
}
--- 841,857 ----
void
read_x (st_parameter_dt *dtp, int n)
{
! if (!is_stream_io (dtp))
! {
! if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
! && dtp->u.p.current_unit->bytes_left < n)
! n = dtp->u.p.current_unit->bytes_left;
+ dtp->u.p.sf_read_comma = 0;
+ if (n > 0)
+ read_sf (dtp, &n, 1);
+ dtp->u.p.sf_read_comma = 1;
+ }
+ else
+ dtp->rec += (GFC_LARGE_IO_INT) n;
}
Index: libgfortran/io/inquire.c
===================================================================
*** libgfortran/io/inquire.c (revision 115887)
--- libgfortran/io/inquire.c (working copy)
*************** inquire_via_unit (st_parameter_inquire *
*** 75,80 ****
--- 75,83 ----
case ACCESS_DIRECT:
p = "DIRECT";
break;
+ case ACCESS_STREAM:
+ p = "STREAM";
+ break;
default:
internal_error (&iqp->common, "inquire_via_unit(): Bad access");
}
Index: libgfortran/io/io.h
===================================================================
*** libgfortran/io/io.h (revision 115887)
--- libgfortran/io/io.h (working copy)
*************** namelist_info;
*** 156,162 ****
/* Options for the OPEN statement. */
typedef enum
! { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND,
ACCESS_UNSPECIFIED
}
unit_access;
--- 156,162 ----
/* Options for the OPEN statement. */
typedef enum
! { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
ACCESS_UNSPECIFIED
}
unit_access;
*************** internal_proto(is_internal_unit);
*** 709,714 ****
--- 709,717 ----
extern int is_array_io (st_parameter_dt *);
internal_proto(is_array_io);
+ extern int is_stream_io (st_parameter_dt *);
+ internal_proto(is_stream_io);
+
extern gfc_unit *find_unit (int);
internal_proto(find_unit);
Index: libgfortran/io/unit.c
===================================================================
*** libgfortran/io/unit.c (revision 115887)
--- libgfortran/io/unit.c (working copy)
*************** is_array_io (st_parameter_dt *dtp)
*** 493,498 ****
--- 493,507 ----
}
+ /* is_stream_io () -- Determine if I/O is access="stream" mode */
+
+ int
+ is_stream_io (st_parameter_dt *dtp)
+ {
+ return dtp->u.p.current_unit->flags.access == ACCESS_STREAM;
+ }
+
+
/*************************/
/* Initialize everything */
Index: libgfortran/io/transfer.c
===================================================================
*** libgfortran/io/transfer.c (revision 115887)
--- libgfortran/io/transfer.c (working copy)
*************** static const st_option advance_opt[] = {
*** 91,97 ****
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
! FORMATTED_DIRECT, UNFORMATTED_DIRECT
}
file_mode;
--- 91,97 ----
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
! FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
}
file_mode;
*************** current_mode (st_parameter_dt *dtp)
*** 101,116 ****
{
file_mode m;
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
! else
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
return m;
}
--- 101,123 ----
{
file_mode m;
+ m = FORM_UNSPECIFIED;
+
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
! else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
+ else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+ {
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+ FORMATTED_STREAM : UNFORMATTED_STREAM;
+ }
return m;
}
*************** current_mode (st_parameter_dt *dtp)
*** 128,134 ****
an I/O error.
Given this, the solution is to read a byte at a time, stopping if
! we hit the newline. For small locations, we use a static buffer.
For larger allocations, we are forced to allocate memory on the
heap. Hopefully this won't happen very often. */
--- 135,141 ----
an I/O error.
Given this, the solution is to read a byte at a time, stopping if
! we hit the newline. For small allocations, we use a static buffer.
For larger allocations, we are forced to allocate memory on the
heap. Hopefully this won't happen very often. */
*************** read_block (st_parameter_dt *dtp, int *l
*** 256,311 ****
char *source;
int nread;
! if (dtp->u.p.current_unit->bytes_left < *length)
{
! /* 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.stdin_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.pad == PAD_NO)
{
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
}
! 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 NULL;
}
! *length = dtp->u.p.current_unit->bytes_left;
! }
!
! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
! dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
! return read_sf (dtp, length, 0); /* Special case. */
!
! dtp->u.p.current_unit->bytes_left -= *length;
!
! nread = *length;
! source = salloc_r (dtp->u.p.current_unit->s, &nread);
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nread;
! if (nread != *length)
! { /* Short read, this shouldn't happen. */
! if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! *length = nread;
! else
! {
! generate_error (&dtp->common, ERROR_EOR, NULL);
! source = NULL;
}
- }
return source;
}
--- 263,347 ----
char *source;
int nread;
! if (!is_stream_io (dtp))
{
! if (dtp->u.p.current_unit->bytes_left < *length)
{
! /* 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.stdin_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.pad == PAD_NO)
! {
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
! }
! }
!
! 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 NULL;
}
+
+ *length = dtp->u.p.current_unit->bytes_left;
}
! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
! dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
! return read_sf (dtp, length, 0); /* Special case. */
!
! dtp->u.p.current_unit->bytes_left -= *length;
!
! nread = *length;
! source = salloc_r (dtp->u.p.current_unit->s, &nread);
!
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nread;
!
! if (nread != *length)
! { /* Short read, this shouldn't happen. */
! if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! *length = nread;
! else
! {
! generate_error (&dtp->common, ERROR_EOR, NULL);
! source = NULL;
! }
! }
! }
! else
! {
! if (sseek (dtp->u.p.current_unit->s, (dtp->rec - 1)) == FAILURE)
{
generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
! nread = *length;
! source = salloc_r (dtp->u.p.current_unit->s, &nread);
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nread;
! if (nread != *length)
! { /* Short read, this shouldn't happen. */
! if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! *length = nread;
! else
! {
! generate_error (&dtp->common, ERROR_END, NULL);
! source = NULL;
! }
}
+ dtp->rec += (GFC_LARGE_IO_INT) nread;
+ }
return source;
}
*************** read_block_direct (st_parameter_dt *dtp,
*** 319,362 ****
void *data;
size_t nread;
! if (dtp->u.p.current_unit->bytes_left < *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.stdin_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.pad == PAD_NO)
{
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
return;
}
}
! 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;
}
! *nbytes = dtp->u.p.current_unit->bytes_left;
}
!
! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
! dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
! length = (int *) nbytes;
! data = read_sf (dtp, length, 0); /* Special case. */
! memcpy (buf, data, (size_t) *length);
! return;
}
- dtp->u.p.current_unit->bytes_left -= *nbytes;
-
nread = *nbytes;
if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
{
--- 355,410 ----
void *data;
size_t nread;
! if (!is_stream_io (dtp))
{
! if (dtp->u.p.current_unit->bytes_left < *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.stdin_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.pad == PAD_NO)
! {
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return;
! }
! }
!
! 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;
}
+
+ *nbytes = dtp->u.p.current_unit->bytes_left;
}
! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
! dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
! length = (int *) nbytes;
! data = read_sf (dtp, length, 0); /* Special case. */
! memcpy (buf, data, (size_t) *length);
return;
}
! dtp->u.p.current_unit->bytes_left -= *nbytes;
}
! else
{
! if (sseek (dtp->u.p.current_unit->s, (gfc_offset)(dtp->rec - 1)) == FAILURE)
! {
! generate_error (&dtp->common, ERROR_END, NULL);
! return;
! }
}
nread = *nbytes;
if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
{
*************** read_block_direct (st_parameter_dt *dtp,
*** 364,381 ****
return;
}
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nread;
! if (nread != *nbytes)
! { /* Short read, e.g. if we hit EOF. */
! if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! {
! memset (((char *) buf) + nread, ' ', *nbytes - nread);
! *nbytes = nread;
! }
! else
generate_error (&dtp->common, ERROR_EOR, NULL);
}
}
--- 412,431 ----
return;
}
! if (!is_stream_io (dtp))
! {
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nread;
! }
! else
! dtp->rec += (GFC_LARGE_IO_INT) nread;
! if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
! {
! if (!is_stream_io (dtp))
generate_error (&dtp->common, ERROR_EOR, NULL);
+ else
+ generate_error (&dtp->common, ERROR_END, NULL);
}
}
*************** write_block (st_parameter_dt *dtp, int l
*** 390,424 ****
{
char *dest;
! if (dtp->u.p.current_unit->bytes_left < length)
{
! /* 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
{
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
}
- }
! dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
! dest = salloc_w (dtp->u.p.current_unit->s, &length);
! if (dest == NULL)
! {
! generate_error (&dtp->common, ERROR_END, NULL);
! return NULL;
}
! if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
! generate_error (&dtp->common, ERROR_END, NULL);
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) length;
return dest;
}
--- 440,497 ----
{
char *dest;
! if (!is_stream_io (dtp))
{
! if (dtp->u.p.current_unit->bytes_left < length)
{
! /* 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
! {
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
! }
}
! dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
!
!
! dest = salloc_w (dtp->u.p.current_unit->s, &length);
! if (dest == NULL)
! {
! generate_error (&dtp->common, ERROR_END, NULL);
! return NULL;
! }
!
! if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
! generate_error (&dtp->common, ERROR_END, NULL);
!
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) length;
}
+ else
+ {
+ if (sseek (dtp->u.p.current_unit->s, (dtp->rec - 1)) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return NULL;
+ }
! dest = salloc_w (dtp->u.p.current_unit->s, &length);
! if (dest == NULL)
! {
! generate_error (&dtp->common, ERROR_END, NULL);
! return NULL;
! }
!
! dtp->rec += (GFC_LARGE_IO_INT) length;
! }
return dest;
}
*************** write_block (st_parameter_dt *dtp, int l
*** 429,462 ****
static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
! if (dtp->u.p.current_unit->bytes_left < 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;
}
}
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
-
if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return FAILURE;
}
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nbytes;
return SUCCESS;
}
--- 502,552 ----
static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
! if (!is_stream_io (dtp))
{
! if (dtp->u.p.current_unit->bytes_left < 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;
! }
! }
!
! dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
! }
! else
! {
! if (sseek (dtp->u.p.current_unit->s, (gfc_offset)(dtp->rec - 1)) == FAILURE)
! {
! 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;
}
! if (!is_stream_io (dtp))
! {
! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! dtp->u.p.size_used += (gfc_offset) nbytes;
! }
! else
! dtp->rec += (GFC_LARGE_IO_INT) nbytes;
return SUCCESS;
}
*************** pre_position (st_parameter_dt *dtp)
*** 1405,1410 ****
--- 1495,1508 ----
switch (current_mode (dtp))
{
+ case FORMATTED_STREAM:
+ case UNFORMATTED_STREAM:
+ /* There are no records with stream I/O. Set the default position
+ to the beginning of the file if no position was specified. */
+ if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
+ dtp->rec = 1;
+ break;
+
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp);
*************** data_transfer_init (st_parameter_dt *dtp
*** 1555,1561 ****
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED data transfer");
! /* Check the record number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
--- 1653,1659 ----
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED data transfer");
! /* Check the record or position number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
*************** data_transfer_init (st_parameter_dt *dtp
*** 1723,1729 ****
if (read_flag)
{
! if (dtp->u.p.current_unit->read_bad)
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
--- 1821,1827 ----
if (read_flag)
{
! if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
*************** next_record_r (st_parameter_dt *dtp)
*** 1813,1818 ****
--- 1911,1921 ----
switch (current_mode (dtp))
{
+ /* No records in STREAM I/O. */
+ case FORMATTED_STREAM:
+ case UNFORMATTED_STREAM:
+ return;
+
case UNFORMATTED_SEQUENTIAL:
/* Skip over tail */
*************** next_record_w (st_parameter_dt *dtp, int
*** 2003,2008 ****
--- 2106,2116 ----
switch (current_mode (dtp))
{
+ /* No records in STREAM I/O. */
+ case FORMATTED_STREAM:
+ case UNFORMATTED_STREAM:
+ return;
+
case FORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left == 0)
break;
*************** next_record_w (st_parameter_dt *dtp, int
*** 2166,2171 ****
--- 2274,2282 ----
void
next_record (st_parameter_dt *dtp, int done)
{
+ if (is_stream_io (dtp))
+ return;
+
gfc_offset fp; /* File position. */
dtp->u.p.current_unit->read_bad = 0;
*************** next_record (st_parameter_dt *dtp, int d
*** 2177,2183 ****
/* keep position up to date for INQUIRE */
dtp->u.p.current_unit->flags.position = POSITION_ASIS;
-
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
--- 2288,2293 ----
*************** finalize_transfer (st_parameter_dt *dtp)
*** 2238,2244 ****
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
finish_list_read (dtp);
! else
{
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
--- 2348,2354 ----
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
finish_list_read (dtp);
! else if (!is_stream_io (dtp))
{
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
*************** finalize_transfer (st_parameter_dt *dtp)
*** 2250,2258 ****
dtp->u.p.seen_dollar = 0;
return;
}
-
next_record (dtp, 1);
}
sfree (dtp->u.p.current_unit->s);
}
--- 2360,2369 ----
dtp->u.p.seen_dollar = 0;
return;
}
next_record (dtp, 1);
}
+ else
+ flush (dtp->u.p.current_unit->s);
sfree (dtp->u.p.current_unit->s);
}
! { dg-do run }
! PR25828 Stream IO test 1
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
PROGRAM stream_io_1
IMPLICIT NONE
integer(kind=4) i
real(kind=8) r
OPEN(UNIT=11, ACCESS="stream")
WRITE(11) "first"
WRITE(11) "second"
WRITE(11) 1234567
write(11) 3.14159_8
read(11, pos=12)i
if (i.ne.1234567) call abort()
read(11) r
if (r-3.14159 .gt. 0.00001) call abort()
CLOSE(UNIT=11, status="delete")
END PROGRAM stream_io_1! { dg-do run }
! PR25828 Stream IO test 2
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
PROGRAM readUstream
IMPLICIT NONE
CHARACTER*3 :: string
INTEGER :: n
string = "123"
n = 13579
OPEN(UNIT=11, FILE="streamio2", ACCESS="STREAM")
WRITE(11) "first"
WRITE(11) "second"
WRITE(11) 7
READ(11, POS=3) string
READ(11, POS=12) n
if (string.ne."rst") call abort()
if (n.ne.7) call abort()
close(unit=11, status="delete")
END PROGRAM readUstream! { dg-do run }
! PR25828 Stream IO test 3, tests read_x and inquire.
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
program streamio_3
implicit none
integer :: i(6),j
character(10) :: myaccess
open(10, access="stream", form="formatted")
i = (/(j,j=1,6)/)
write(10,'(3(2x,i4/)/3(3x,i6/))') i
i = 0
rewind(10)
read(10,'(3(2x,i4/)/3(3x,i6/))') i
if (any(i.ne.(/(j,j=1,6)/))) call abort()
inquire(unit=10, access=myaccess)
if (myaccess.ne."STREAM") call abort()
close(10,status="delete")
end program streamio_3! { dg-do run }
! PR25828 Stream IO test 4, Tests string read and writes, single byte.
! Verifies buffering is working correctly and position="append"
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
program streamtest
implicit none
character(1) :: lf = char(10)
character(1) :: tchar
integer :: i,j,k
integer, parameter :: lines = 5231
open(10, file="teststream", access="stream", form="formatted")
do i=1,lines
do j=0,9
write(10,"(i5)") j
end do
write(10,"(a)") lf
end do
close(10)
open(10, file="teststream", access="stream",&
&form="formatted", position="append")
do i=1,lines
do j=0,9
write(10,"(i5)") j
end do
write(10,"(a)") lf
end do
rewind(10)
do i=1,lines
do j=0,9
read(10,"(i5)") k
if (k.ne.j) call abort()
end do
read(10,"(a)") tchar
if (tchar.ne.lf) call abort()
end do
close(10,status="delete")
end program streamtest! { dg-do run }
! PR25828 Stream IO test 5, unformatted single byte
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
program streamtest5
implicit none
character(1) :: lf = char(10)
character(1) :: tchar
integer :: i,j,k
open(10, file="teststream", access="stream", form="unformatted")
do i=1,1229
do j=0,9
write(10) j
end do
write(10) lf
end do
close(10)
open(10, file="teststream", access="stream", form="unformatted")
do i=1,1229
do j=0,9
read(10) k
if (k.ne.j) call abort()
end do
read(10) tchar
if (tchar.ne.lf) call abort()
end do
close(10,status="delete")
end program streamtest5! { dg-do run }
! PR25828 Stream IO test 6, random writes and reads.
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
program streamio_6
implicit none
integer, dimension(100) :: a
character(1) :: c
integer :: i,j,k,ier
real :: x
data a / 13, 9, 34, 41, 25, 98, 6, 12, 11, 44, 79, 3,&
& 64, 61, 77, 57, 59, 2, 92, 38, 71, 64, 31, 60, 28, 90, 26,&
& 97, 47, 26, 48, 96, 95, 82, 100, 90, 45, 71, 71, 67, 72,&
& 76, 94, 49, 85, 45, 100, 22, 96, 48, 13, 23, 40, 14, 76, 99,&
& 96, 90, 65, 2, 8, 60, 96, 19, 45, 1, 100, 48, 91, 20, 92,&
& 72, 81, 59, 24, 37, 43, 21, 54, 68, 31, 19, 79, 63, 41,&
& 42, 12, 10, 62, 43, 9, 30, 9, 54, 35, 4, 5, 55, 3, 94 /
open(unit=15,file="teststream",access="stream",form="unformatted")
do i=1,100
k = a(i)
write(unit=15, pos=k) achar(k)
enddo
do j=1,100
read(unit=15, pos=a(j), iostat=ier) c
if (ier.ne.0) then
call abort
else
if (achar(a(j)) /= c) call abort
endif
enddo
close(unit=15, status="delete")
end program streamio_6! { dg-do run }
! PR25828 Stream IO test 7, Array writes and reads.
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
program streamtest
implicit none
character(1) :: lf = char(10)
character(1) :: tchar
integer :: i,j,k
real(kind=4), dimension(100,100) :: anarray
open(10, file="teststream", access="stream", form="unformatted")
anarray = 3.14159
write(10) anarray
write(10, pos=1) ! This is a way to position an unformatted file
anarray = 0.0
read(10) anarray
anarray = abs(anarray - 3.14159)
if (any(anarray.gt.0.00001)) call abort()
close(10,status="delete")
end program streamtest