This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [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>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 05 Aug 2006 14:26:40 -0700
- Subject: Re: [patch,fortran] PR25828 F2003 Stream I/O
- References: <44D191BD.3030303@verizon.net>
:REVIEWMAIL:
Jerry DeLisle wrote:
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.
The new attached patch is against current trunk and adds the INQUIRE "POS="
functionality to the previous patch. (This attached patch has all stream io
contained)
This is implemented by passing the file position value dtp->rec to
dtp-u.p.current_unit->next_record. Next_record is readily accessible by the
INQUIRE facility. The value is passed over in finalize_transfer so that at the
conclusion of each data transfer, the value is updated.
Attached preliminary test case provided as well.
Regards,
Jerry
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 115887)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 1465,1471 ****
gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
*name, *access, *sequential, *direct, *form, *formatted,
*unformatted, *recl, *nextrec, *blank, *position, *action, *read,
! *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert;
gfc_st_label *err;
--- 1465,1471 ----
gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
*name, *access, *sequential, *direct, *form, *formatted,
*unformatted, *recl, *nextrec, *blank, *position, *action, *read,
! *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos;
gfc_st_label *err;
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},
*************** static const io_tag
*** 79,84 ****
--- 80,86 ----
tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER},
tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER},
tag_convert = {"CONVERT", " convert = %e", BT_CHARACTER},
+ tag_strm_out = {"POS", " pos = %v", BT_INTEGER},
tag_err = {"ERR", " err = %l", BT_UNKNOWN},
tag_end = {"END", " end = %l", BT_UNKNOWN},
tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
*************** match_dt_element (io_kind k, gfc_dt * dt
*** 1784,1789 ****
--- 1786,1794 ----
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 ****
--- 1860,1866 ----
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);
*************** gfc_free_inquire (gfc_inquire * inquire)
*** 2643,2648 ****
--- 2649,2655 ----
gfc_free_expr (inquire->pad);
gfc_free_expr (inquire->iolength);
gfc_free_expr (inquire->convert);
+ gfc_free_expr (inquire->strm_pos);
gfc_free (inquire);
}
*************** match_inquire_element (gfc_inquire * inq
*** 2685,2690 ****
--- 2692,2698 ----
RETM m = match_vtag (&tag_s_pad, &inquire->pad);
RETM m = match_vtag (&tag_iolength, &inquire->iolength);
RETM m = match_vtag (&tag_convert, &inquire->convert);
+ RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
RETM return MATCH_NO;
}
*************** gfc_resolve_inquire (gfc_inquire * inqui
*** 2839,2844 ****
--- 2847,2853 ----
RESOLVE_TAG (&tag_s_pad, inquire->pad);
RESOLVE_TAG (&tag_iolength, inquire->iolength);
RESOLVE_TAG (&tag_convert, inquire->convert);
+ RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 115887)
--- gcc/fortran/trans-io.c (working copy)
*************** Software Foundation, 51 Franklin Street,
*** 35,41 ****
#include "trans-types.h"
#include "trans-const.h"
-
/* Members of the ioparm structure. */
enum ioparam_type
--- 35,40 ----
*************** gfc_trans_inquire (gfc_code * code)
*** 1098,1103 ****
--- 1097,1106 ----
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
p->convert);
+ if (p->strm_pos)
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_strm_pos_out, p->strm_pos);
+
set_parameter_const (&block, var, IOPARM_common_flags, mask);
tmp = build_fold_addr_expr (var);
Index: gcc/fortran/ioparm.def
===================================================================
*** gcc/fortran/ioparm.def (revision 115887)
--- gcc/fortran/ioparm.def (working copy)
*************** IOPARM (inquire, read, 1 << 26, char2)
*** 53,58 ****
--- 53,59 ----
IOPARM (inquire, write, 1 << 27, char1)
IOPARM (inquire, readwrite, 1 << 28, char2)
IOPARM (inquire, convert, 1 << 29, char1)
+ IOPARM (inquire, strm_pos_out, 1 << 30, pint4)
#ifndef IOPARM_dt_list_format
#define IOPARM_dt_list_format (1 << 7)
#define IOPARM_dt_namelist_read_mode (1 << 8)
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,447 ----
if (flags->access == ACCESS_DIRECT)
u->maxrec = max_offset / u->recl;
+
+ if (flags->access == ACCESS_STREAM)
+ {
+ u->maxrec = max_offset;
+ u->recl = 1;
+ u->last_record = 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_offset) 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");
}
*************** inquire_via_unit (st_parameter_inquire *
*** 145,150 ****
--- 148,156 ----
if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
*iqp->recl_out = (u != NULL) ? u->recl : 0;
+ if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
+ *iqp->strm_pos_out = (u != NULL) ? u->last_record : 0;
+
if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
*iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
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;
*************** st_parameter_filepos;
*** 307,312 ****
--- 307,313 ----
#define IOPARM_INQUIRE_HAS_WRITE (1 << 27)
#define IOPARM_INQUIRE_HAS_READWRITE (1 << 28)
#define IOPARM_INQUIRE_HAS_CONVERT (1 << 29)
+ #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 30)
typedef struct
{
*************** typedef struct
*** 330,335 ****
--- 331,337 ----
CHARACTER1 (write);
CHARACTER2 (readwrite);
CHARACTER1 (convert);
+ GFC_LARGE_IO_INT *strm_pos_out;
}
st_parameter_inquire;
*************** internal_proto(is_internal_unit);
*** 709,714 ****
--- 711,719 ----
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,348 ----
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_offset) 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)
{
--- 356,412 ----
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);
}
}
--- 414,433 ----
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_offset) 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;
}
--- 442,500 ----
{
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_offset) 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;
}
--- 505,556 ----
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_offset) nbytes;
return SUCCESS;
}
*************** formatted_transfer_scalar (st_parameter_
*** 721,727 ****
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
! bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
switch (t)
{
--- 815,822 ----
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
! bytes_used = (int)(dtp->u.p.current_unit->recl
! - dtp->u.p.current_unit->bytes_left);
switch (t)
{
*************** pre_position (st_parameter_dt *dtp)
*** 1405,1410 ****
--- 1500,1513 ----
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)
--- 1658,1664 ----
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");
--- 1826,1832 ----
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 ****
--- 1916,1926 ----
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 ****
--- 2111,2121 ----
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 ****
--- 2279,2287 ----
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)
{
--- 2293,2298 ----
*************** 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)
--- 2353,2359 ----
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);
}
--- 2365,2377 ----
dtp->u.p.seen_dollar = 0;
return;
}
next_record (dtp, 1);
}
+ else
+ {
+ flush (dtp->u.p.current_unit->s);
+ dtp->u.p.current_unit->last_record = dtp->rec;
+ }
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
integer(kind=8) mypos
character(10) mystring
real(kind=8) r
mypos = 0
mystring = "not yet"
OPEN(UNIT=11, ACCESS="stream")
inquire(unit=11, pos=mypos)
print *, mypos, mystring
WRITE(11) "first"
inquire(unit=11, pos=mypos)
print *, mypos, mystring
WRITE(11) "second"
inquire(unit=11, pos=mypos)
print *, mypos, mystring
WRITE(11) 1234567
inquire(unit=11, pos=mypos)
print *, mypos, mystring
write(11) 3.14159_8
inquire(unit=11, pos=mypos)
inquire(unit=11, access=mystring)
CLOSE(UNIT=11, status="keep")
print *, mypos, mystring
END PROGRAM stream_io_1