Skip to content

R
riscv-gcc-1
Commit f3ed1d02 by Janne Blomqvist
Options

Revert part of patch accidentally committed to trunk rather than fortran-dev (I hate svn) 

From-SVN: r144994
parent 9e544d73
Showing with 370 additions and 460 deletions
libgfortran/io/io.h
......@@ -49,59 +49,34 @@ struct st_parameter_dt;
typedef struct stream
{
ssize_t (*read) (struct stream *, void *, ssize_t);
ssize_t (*write) (struct stream *, const void *, ssize_t);
off_t (*seek) (struct stream *, off_t, int);
off_t (*tell) (struct stream *);
int (*truncate) (struct stream *, off_t);
int (*flush) (struct stream *);
int (*close) (struct stream *);
char *(*alloc_w_at) (struct stream *, int *);
try (*sfree) (struct stream *);
try (*close) (struct stream *);
try (*seek) (struct stream *, gfc_offset);
try (*trunc) (struct stream *);
int (*read) (struct stream *, void *, size_t *);
int (*write) (struct stream *, const void *, size_t *);
try (*set) (struct stream *, int, size_t);
}
stream;
/* Inline functions for doing file I/O given a stream. */
static inline ssize_t
sread (stream * s, void * buf, ssize_t nbyte)
{
return s->read (s, buf, nbyte);
}
typedef enum
{ SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
io_mode;
static inline ssize_t
swrite (stream * s, const void * buf, ssize_t nbyte)
{
return s->write (s, buf, nbyte);
}
/* Macros for doing file I/O given a stream. */
static inline off_t
sseek (stream * s, off_t offset, int whence)
{
return s->seek (s, offset, whence);
}
#define sfree(s) ((s)->sfree)(s)
#define sclose(s) ((s)->close)(s)
static inline off_t
stell (stream * s)
{
return s->tell (s);
}
#define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
static inline int
struncate (stream * s, off_t length)
{
return s->truncate (s, length);
}
static inline int
sflush (stream * s)
{
return s->flush (s);
}
static inline int
sclose (stream * s)
{
return s->close (s);
}
#define sseek(s, pos) ((s)->seek)(s, pos)
#define struncate(s) ((s)->trunc)(s)
#define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
#define sset(s, c, n) ((s)->set)(s, c, n)
/* Macros for testing what kinds of I/O we are doing. */
......@@ -563,9 +538,10 @@ unit_flags;
typedef struct fbuf
{
char *buf; /* Start of buffer. */
int len; /* Length of buffer. */
int act; /* Active bytes in buffer. */
int pos; /* Current position in buffer. */
size_t len; /* Length of buffer. */
size_t act; /* Active bytes in buffer. */
size_t flushed; /* Flushed bytes from beginning of buffer. */
size_t pos; /* Current position in buffer. */
}
fbuf;
......@@ -707,12 +683,6 @@ internal_proto(open_external);
extern stream *open_internal (char *, int, gfc_offset);
internal_proto(open_internal);
extern char * mem_alloc_w (stream *, int *);
internal_proto(mem_alloc_w);
extern char * mem_alloc_r (stream *, int *);
internal_proto(mem_alloc_w);
extern stream *input_stream (void);
internal_proto(input_stream);
......@@ -728,6 +698,12 @@ internal_proto(compare_file_filename);
extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
internal_proto(find_file);
extern int stream_at_bof (stream *);
internal_proto(stream_at_bof);
extern int stream_at_eof (stream *);
internal_proto(stream_at_eof);
extern int delete_file (gfc_unit *);
internal_proto(delete_file);
......@@ -758,6 +734,9 @@ internal_proto(inquire_readwrite);
extern gfc_offset file_length (stream *);
internal_proto(file_length);
extern gfc_offset file_position (stream *);
internal_proto(file_position);
extern int is_seekable (stream *);
internal_proto(is_seekable);
......@@ -773,12 +752,18 @@ internal_proto(flush_if_preconnected);
extern void empty_internal_buffer(stream *);
internal_proto(empty_internal_buffer);
extern try flush (stream *);
internal_proto(flush);
extern int stream_isatty (stream *);
internal_proto(stream_isatty);
extern char * stream_ttyname (stream *);
internal_proto(stream_ttyname);
extern gfc_offset stream_offset (stream *s);
internal_proto(stream_offset);
extern int unpack_filename (char *, const char *, int);
internal_proto(unpack_filename);
......@@ -822,9 +807,6 @@ internal_proto(update_position);
extern void finish_last_advance_record (gfc_unit *u);
internal_proto (finish_last_advance_record);
extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
internal_proto (unit_truncate);
/* open.c */
extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
......@@ -854,7 +836,7 @@ internal_proto(free_format_data);
extern const char *type_name (bt);
internal_proto(type_name);
extern void * read_block_form (st_parameter_dt *, int *);
extern try read_block_form (st_parameter_dt *, void *, size_t *);
internal_proto(read_block_form);
extern char *read_sf (st_parameter_dt *, int *, int);
......@@ -880,9 +862,6 @@ internal_proto (reverse_memcpy);
extern void st_wait (st_parameter_wait *);
export_proto(st_wait);
extern void hit_eof (st_parameter_dt *);
internal_proto(hit_eof);
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
......@@ -989,39 +968,24 @@ extern size_t size_from_complex_kind (int);
internal_proto(size_from_complex_kind);
/* fbuf.c */
extern void fbuf_init (gfc_unit *, int);
extern void fbuf_init (gfc_unit *, size_t);
internal_proto(fbuf_init);
extern void fbuf_destroy (gfc_unit *);
internal_proto(fbuf_destroy);
extern int fbuf_reset (gfc_unit *);
extern void fbuf_reset (gfc_unit *);
internal_proto(fbuf_reset);
extern char * fbuf_alloc (gfc_unit *, int);
extern char * fbuf_alloc (gfc_unit *, size_t);
internal_proto(fbuf_alloc);
extern int fbuf_flush (gfc_unit *, unit_mode);
extern int fbuf_flush (gfc_unit *, int);
internal_proto(fbuf_flush);
extern int fbuf_seek (gfc_unit *, int, int);
extern int fbuf_seek (gfc_unit *, gfc_offset);
internal_proto(fbuf_seek);
extern char * fbuf_read (gfc_unit *, int *);
internal_proto(fbuf_read);
/* Never call this function, only use fbuf_getc(). */
extern int fbuf_getc_refill (gfc_unit *);
internal_proto(fbuf_getc_refill);
static inline int
fbuf_getc (gfc_unit * u)
{
if (u->fbuf->pos < u->fbuf->act)
return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
return fbuf_getc_refill (u);
}
/* lock.c */
extern void free_ionml (st_parameter_dt *);
internal_proto(free_ionml);
......
libgfortran/io/list_read.c
......@@ -33,7 +33,6 @@ Boston, MA 02110-1301, USA. */
#include "io.h"
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
......@@ -80,8 +79,9 @@ push_char (st_parameter_dt *dtp, char c)
if (dtp->u.p.saved_string == NULL)
{
dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
// memset below should be commented out.
if (dtp->u.p.scratch == NULL)
dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
dtp->u.p.saved_string = dtp->u.p.scratch;
memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
......@@ -90,15 +90,15 @@ push_char (st_parameter_dt *dtp, char c)
if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
{
dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
if (new == NULL)
generate_error (&dtp->common, LIBERROR_OS, NULL);
dtp->u.p.saved_string = new;
new = get_mem (2 * dtp->u.p.saved_length);
// Also this should not be necessary.
memset (new + dtp->u.p.saved_used, 0,
dtp->u.p.saved_length - dtp->u.p.saved_used);
memset (new, 0, 2 * dtp->u.p.saved_length);
memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
if (dtp->u.p.saved_string != dtp->u.p.scratch)
free_mem (dtp->u.p.saved_string);
dtp->u.p.saved_string = new;
}
dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
......@@ -113,6 +113,7 @@ free_saved (st_parameter_dt *dtp)
if (dtp->u.p.saved_string == NULL)
return;
if (dtp->u.p.saved_string != dtp->u.p.scratch)
free_mem (dtp->u.p.saved_string);
dtp->u.p.saved_string = NULL;
......@@ -139,10 +140,9 @@ free_line (st_parameter_dt *dtp)
static char
next_char (st_parameter_dt *dtp)
{
ssize_t length;
size_t length;
gfc_offset record;
char c;
int cc;
if (dtp->u.p.last_char != '\0')
{
......@@ -194,7 +194,7 @@ next_char (st_parameter_dt *dtp)
}
record *= dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
longjmp (*dtp->u.p.eof_jump, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
......@@ -204,15 +204,19 @@ next_char (st_parameter_dt *dtp)
/* Get the next character and handle end-of-record conditions. */
if (is_internal_unit (dtp))
{
length = sread (dtp->u.p.current_unit->s, &c, 1);
if (length < 0)
length = 1;
if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return '\0';
}
if (is_stream_io (dtp) && length == 1)
dtp->u.p.current_unit->strm_pos++;
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
{
/* Check whether we hit EOF. */
......@@ -236,20 +240,13 @@ next_char (st_parameter_dt *dtp)
}
else
{
cc = fbuf_getc (dtp->u.p.current_unit);
if (cc == EOF)
if (length == 0)
{
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
longjmp (*dtp->u.p.eof_jump, 1);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
c = '\n';
}
else
c = (char) cc;
if (is_stream_io (dtp) && cc != EOF)
dtp->u.p.current_unit->strm_pos++;
}
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
......@@ -1856,8 +1853,6 @@ finish_list_read (st_parameter_dt *dtp)
free_saved (dtp);
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
if (dtp->u.p.at_eol)
{
dtp->u.p.at_eol = 0;
......@@ -2266,8 +2261,8 @@ nml_query (st_parameter_dt *dtp, char c)
/* Flush the stream to force immediate output. */
fbuf_flush (dtp->u.p.current_unit, WRITING);
sflush (dtp->u.p.current_unit->s);
fbuf_flush (dtp->u.p.current_unit, 1);
flush (dtp->u.p.current_unit->s);
unlock_unit (dtp->u.p.current_unit);
}
......@@ -2908,7 +2903,7 @@ find_nml_name:
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
sflush (u->s);
flush (u->s);
unlock_unit (u);
}
}
......
libgfortran/io/transfer.c
......@@ -37,7 +37,6 @@ Boston, MA 02110-1301, USA. */
#include <string.h>
#include <assert.h>
#include <stdlib.h>
#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
......@@ -184,58 +183,60 @@ current_mode (st_parameter_dt *dtp)
heap. Hopefully this won't happen very often. */
char *
read_sf (st_parameter_dt *dtp, int * length, int no_error)
read_sf (st_parameter_dt *dtp, int *length, int no_error)
{
static char *empty_string[0];
char *base, *p, q;
int n, lorig, memread, seen_comma;
int n, crlf;
gfc_offset pos;
size_t readlen;
/* If we hit EOF previously with the no_error flag set (i.e. X, T,
TR edit descriptors), and we now try to read again, this time
without setting no_error. */
if (!no_error && dtp->u.p.at_eof)
{
*length = 0;
hit_eof (dtp);
return NULL;
}
if (*length > SCRATCH_SIZE)
dtp->u.p.line_buffer = get_mem (*length);
p = base = dtp->u.p.line_buffer;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
if (dtp->u.p.sf_seen_eor)
{
*length = 0;
/* Just return something that isn't a NULL pointer, otherwise the
caller thinks an error occured. */
return (char*) empty_string;
return base;
}
if (is_internal_unit (dtp))
{
memread = *length;
base = mem_alloc_r (dtp->u.p.current_unit->s, length);
if (unlikely (memread > *length))
readlen = *length;
if (unlikely (sread (dtp->u.p.current_unit->s, p, &readlen) != 0
|| readlen < (size_t) *length))
{
hit_eof (dtp);
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
n = *length;
goto done;
}
n = seen_comma = 0;
readlen = 1;
n = 0;
/* Read data into format buffer and scan through it. */
lorig = *length;
base = p = fbuf_read (dtp->u.p.current_unit, length);
if (base == NULL)
do
{
if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0))
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
while (n < *length)
/* If we have a line without a terminating \n, drop through to
EOR below. */
if (readlen < 1 && n == 0)
{
q = *p;
if (likely (no_error))
break;
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
if (q == '\n' || q == '\r')
if (readlen < 1 || q == '\n' || q == '\r')
{
/* Unexpected end of line. */
......@@ -244,14 +245,23 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
crlf = 0;
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
if (n < *length && *(p + 1) == '\n')
dtp->u.p.sf_seen_eor = 2;
readlen = 1;
pos = stream_offset (dtp->u.p.current_unit->s);
if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen)
!= 0))
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
if (q != '\n' && readlen == 1) /* Not a CRLF after all. */
sseek (dtp->u.p.current_unit->s, pos);
else
dtp->u.p.sf_seen_eor = 1;
crlf = 1;
}
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
......@@ -265,6 +275,7 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
}
*length = n;
dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
break;
}
/* Short circuit the read if a comma is found during numeric input.
......@@ -273,7 +284,6 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
if (q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
seen_comma = 1;
notify_std (&dtp->common, GFC_STD_GNU,
"Comma in formatted numeric read.");
*length = n;
......@@ -281,31 +291,16 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
}
n++;
p++;
}
fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + seen_comma,
SEEK_CUR);
/* A short read implies we hit EOF, unless we hit EOR, a comma, or
some other stuff. Set the relevant flags. */
if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
{
if (no_error)
dtp->u.p.at_eof = 1;
else
{
hit_eof (dtp);
return NULL;
}
*p++ = q;
dtp->u.p.sf_seen_eor = 0;
}
while (n < *length);
done:
dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->bytes_left -= *length;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) n;
dtp->u.p.size_used += (GFC_IO_INT) *length;
return base;
}
......@@ -321,11 +316,12 @@ read_sf (st_parameter_dt *dtp, int * length, int no_error)
opened with PAD=YES. The caller must assume tailing spaces for
short reads. */
void *
read_block_form (st_parameter_dt *dtp, int * nbytes)
try
read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
char *source;
int norig;
size_t nread;
int nb;
if (!is_stream_io (dtp))
{
......@@ -342,14 +338,15 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
{
/* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL;
return FAILURE;
}
}
if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
{
hit_eof (dtp);
return NULL;
dtp->u.p.current_unit->endfile = AT_ENDFILE;
generate_error (&dtp->common, LIBERROR_END, NULL);
return FAILURE;
}
*nbytes = dtp->u.p.current_unit->bytes_left;
......@@ -360,36 +357,42 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
(dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
{
source = read_sf (dtp, nbytes, 0);
nb = *nbytes;
source = read_sf (dtp, &nb, 0);
*nbytes = nb;
dtp->u.p.current_unit->strm_pos +=
(gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
return source;
if (source == NULL)
return FAILURE;
memcpy (buf, source, *nbytes);
return SUCCESS;
}
/* If we reach here, we can assume it's direct access. */
dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
norig = *nbytes;
source = fbuf_read (dtp->u.p.current_unit, nbytes);
fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
nread = *nbytes;
if (unlikely (sread (dtp->u.p.current_unit->s, buf, &nread) != 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE;
}
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
dtp->u.p.size_used += (GFC_IO_INT) nread;
if (norig != *nbytes)
{
/* Short read, this shouldn't happen. */
if (!dtp->u.p.current_unit->pad_status == PAD_YES)
if (nread != *nbytes)
{ /* Short read, this shouldn't happen. */
if (likely (dtp->u.p.current_unit->pad_status == PAD_YES))
*nbytes = nread;
else
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL;
}
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
return source;
return SUCCESS;
}
......@@ -399,18 +402,18 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
ssize_t to_read_record;
ssize_t have_read_record;
ssize_t to_read_subrecord;
ssize_t have_read_subrecord;
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))
{
to_read_record = *nbytes;
have_read_record = sread (dtp->u.p.current_unit->s, buf,
to_read_record);
if (unlikely (have_read_record < 0))
have_read_record = to_read_record;
if (unlikely (sread (dtp->u.p.current_unit->s, buf, &have_read_record)
!= 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
......@@ -422,7 +425,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
/* Short read, e.g. if we hit EOF. For stream files,
we have to set the end-of-file condition. */
hit_eof (dtp);
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
return;
......@@ -445,14 +448,14 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
dtp->u.p.current_unit->bytes_left -= to_read_record;
to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
if (unlikely (to_read_record < 0))
if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record)
!= 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
if (to_read_record != (ssize_t) *nbytes)
if (to_read_record != *nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
......@@ -472,12 +475,18 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
until the request has been fulfilled or the record has run out
of continuation subrecords. */
if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
/* Check whether we exceed the total record length. */
if (dtp->u.p.current_unit->flags.has_recl
&& (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
{
to_read_record = (ssize_t) dtp->u.p.current_unit->bytes_left;
to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
......@@ -492,7 +501,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (dtp->u.p.current_unit->bytes_left_subrecord
< (gfc_offset) to_read_record)
{
to_read_subrecord = (ssize_t) dtp->u.p.current_unit->bytes_left_subrecord;
to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
to_read_record -= to_read_subrecord;
}
else
......@@ -503,9 +512,9 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord) < 0)
have_read_subrecord = to_read_subrecord;
if (unlikely (sread (dtp->u.p.current_unit->s, buf + have_read_record,
&have_read_subrecord) != 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
......@@ -594,7 +603,7 @@ write_block (st_parameter_dt *dtp, int length)
if (is_internal_unit (dtp))
{
dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
dest = salloc_w (dtp->u.p.current_unit->s, &length);
if (dest == NULL)
{
......@@ -632,22 +641,20 @@ static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
ssize_t have_written;
ssize_t to_write_subrecord;
size_t have_written, to_write_subrecord;
int short_record;
/* Stream I/O. */
if (is_stream_io (dtp))
{
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
return SUCCESS;
}
......@@ -665,15 +672,14 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (buf == NULL && nbytes == 0)
return SUCCESS;
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
return SUCCESS;
}
......@@ -703,9 +709,8 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
if (unlikely (swrite (dtp->u.p.current_unit->s, buf + have_written,
&to_write_subrecord) != 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE;
......@@ -927,6 +932,7 @@ static void
formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
char scratch[SCRATCH_SIZE];
int pos, bytes_used;
const fnode *f;
format_token t;
......@@ -953,6 +959,8 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.line_buffer = scratch;
for (;;)
{
/* If reversion has occurred and there is another real data item,
......@@ -1002,7 +1010,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
if (is_internal_unit (dtp))
move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
}
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
......@@ -1243,6 +1251,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
dtp->u.p.skips += f->u.n;
pos = bytes_used + dtp->u.p.skips - 1;
dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
/* Writes occur just before the switch on f->format, above, so
that trailing blanks are suppressed, unless we are doing a
non-advancing write in which case we want to output the blanks
......@@ -1307,17 +1316,24 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
/* Adjust everything for end-of-record condition */
if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
{
dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
if (dtp->u.p.sf_seen_eor == 2)
{
/* The EOR was a CRLF (two bytes wide). */
dtp->u.p.current_unit->bytes_left -= 2;
dtp->u.p.skips -= 2;
}
else
{
/* The EOR marker was only one byte wide. */
dtp->u.p.current_unit->bytes_left--;
dtp->u.p.skips--;
}
bytes_used = pos;
dtp->u.p.sf_seen_eor = 0;
}
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
dtp->u.p.current_unit->bytes_left
-= (gfc_offset) dtp->u.p.skips;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
......@@ -1393,6 +1409,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
internal_error (&dtp->common, "Bad format node");
}
/* Free a buffer that we had to allocate during a sequential
formatted read of a block that was larger than the static
buffer. */
if (dtp->u.p.line_buffer != scratch)
{
free_mem (dtp->u.p.line_buffer);
dtp->u.p.line_buffer = scratch;
}
/* Adjust the item count and data pointer. */
if ((consume_data_flag > 0) && (n > 0))
......@@ -1631,28 +1657,34 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
static void
us_read (st_parameter_dt *dtp, int continued)
{
ssize_t n, nr;
size_t n, nr;
GFC_INTEGER_4 i4;
GFC_INTEGER_8 i8;
gfc_offset i;
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
return;
if (compile_options.record_marker == 0)
n = sizeof (GFC_INTEGER_4);
else
n = compile_options.record_marker;
nr = sread (dtp->u.p.current_unit->s, &i, n);
if (unlikely (nr < 0))
nr = n;
if (unlikely (sread (dtp->u.p.current_unit->s, &i, &n) != 0))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
}
else if (nr == 0)
if (n == 0)
{
hit_eof (dtp);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
return; /* end of file */
}
else if (unlikely (n != nr))
if (unlikely (n != nr))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
......@@ -1718,7 +1750,7 @@ us_read (st_parameter_dt *dtp, int continued)
static void
us_write (st_parameter_dt *dtp, int continued)
{
ssize_t nbytes;
size_t nbytes;
gfc_offset dummy;
dummy = 0;
......@@ -1728,7 +1760,7 @@ us_write (st_parameter_dt *dtp, int continued)
else
nbytes = compile_options.record_marker ;
if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
/* For sequential unformatted, if RECL= was not specified in the OPEN
......@@ -1930,7 +1962,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
/* Check the record or position number. */
/* Check the record number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
......@@ -2080,17 +2112,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
/* Check to see if we might be reading what we wrote before */
if (dtp->u.p.mode != dtp->u.p.current_unit->mode
&& !is_internal_unit (dtp))
{
int pos = fbuf_reset (dtp->u.p.current_unit);
if (pos != 0)
sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
sflush(dtp->u.p.current_unit->s);
}
/* Check the POS= specifier: that it is in range and that it is used with a
unit that has been connected for STREAM access. F2003 9.5.1.10. */
......@@ -2117,17 +2138,23 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.mode == READING)
{
/* Reset the endfile flag; if we hit EOF during reading
we'll set the flag and generate an error at that point
rather than worrying about it here. */
/* Required for compatibility between 4.3 and 4.4 runtime. Check
to see if we might be reading what we wrote before */
if (dtp->u.p.current_unit->mode == WRITING)
{
fbuf_flush (dtp->u.p.current_unit, 1);
flush(dtp->u.p.current_unit->s);
}
if (dtp->pos < file_length (dtp->u.p.current_unit->s))
dtp->u.p.current_unit->endfile = NO_ENDFILE;
}
if (dtp->pos != dtp->u.p.current_unit->strm_pos)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
sflush (dtp->u.p.current_unit->s);
if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
fbuf_flush (dtp->u.p.current_unit, 1);
flush (dtp->u.p.current_unit->s);
if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
......@@ -2144,7 +2171,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
}
}
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
......@@ -2162,10 +2188,15 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
/* Make sure format buffer is reset. */
if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
fbuf_reset (dtp->u.p.current_unit);
/* Check to see if we might be reading what we wrote before */
if (dtp->u.p.mode == READING
&& dtp->u.p.current_unit->mode == WRITING
&& !is_internal_unit (dtp))
{
fbuf_flush (dtp->u.p.current_unit, 1);
flush(dtp->u.p.current_unit->s);
}
/* Check whether the record exists to be read. Only
a partial record needs to exist. */
......@@ -2180,7 +2211,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
* dtp->u.p.current_unit->recl, SEEK_SET) < 0)
* dtp->u.p.current_unit->recl) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
......@@ -2200,8 +2231,17 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
"data transfer");
return;
} */
}
/* Overwriting an existing sequential file ?
it is always safe to truncate the file on the first write */
if (dtp->u.p.mode == WRITING
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& dtp->u.p.current_unit->last_record == 0
&& !is_preconnected(dtp->u.p.current_unit->s))
struncate(dtp->u.p.current_unit->s);
/* Bugware for badly written mixed C-Fortran I/O. */
flush_if_preconnected(dtp->u.p.current_unit->s);
......@@ -2354,8 +2394,8 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
static void
skip_record (st_parameter_dt *dtp, size_t bytes)
{
gfc_offset new;
size_t rlength;
ssize_t readb;
static const size_t MAX_READ = 4096;
char p[MAX_READ];
......@@ -2365,10 +2405,12 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
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,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
generate_error (&dtp->common, LIBERROR_OS, NULL);
}
else
......@@ -2376,17 +2418,16 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
rlength =
(MAX_READ < (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
(MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
readb = sread (dtp->u.p.current_unit->s, p, rlength);
if (readb < 0)
if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
dtp->u.p.current_unit->bytes_left_subrecord -= readb;
dtp->u.p.current_unit->bytes_left_subrecord -= rlength;
}
}
......@@ -2434,8 +2475,8 @@ next_record_r (st_parameter_dt *dtp)
{
gfc_offset record;
int bytes_left;
size_t length;
char p;
int cc;
switch (current_mode (dtp))
{
......@@ -2455,12 +2496,11 @@ next_record_r (st_parameter_dt *dtp)
case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
/* read_sf has already terminated input because of an '\n', or
we have hit EOF. */
if (dtp->u.p.sf_seen_eor || dtp->u.p.at_eof)
length = 1;
/* sf_read has already terminated input because of an '\n' */
if (dtp->u.p.sf_seen_eor)
{
dtp->u.p.sf_seen_eor = 0;
dtp->u.p.at_eof = 0;
break;
}
......@@ -2475,7 +2515,7 @@ next_record_r (st_parameter_dt *dtp)
/* Now seek to this record. */
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break;
......@@ -2487,9 +2527,10 @@ next_record_r (st_parameter_dt *dtp)
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
bytes_left = min_off (bytes_left,
file_length (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
- file_position (dtp->u.p.current_unit->s));
if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
file_position (dtp->u.p.current_unit->s)
+ bytes_left) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break;
......@@ -2499,37 +2540,42 @@ next_record_r (st_parameter_dt *dtp)
}
break;
}
else
else do
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
if (cc == EOF)
if (sread (dtp->u.p.current_unit->s, &p, &length) != 0)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
else
hit_eof (dtp);
break;
}
if (length == 0)
{
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
p = (char) cc;
}
while (p != '\n');
}
break;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& !dtp->u.p.namelist_mode
&& dtp->u.p.current_unit->endfile == NO_ENDFILE
&& (file_length (dtp->u.p.current_unit->s) ==
file_position (dtp->u.p.current_unit->s)))
dtp->u.p.current_unit->endfile = AT_ENDFILE;
}
/* Small utility function to write a record marker, taking care of
byte swapping and of choosing the correct size. */
static int
inline static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
size_t len;
......@@ -2549,12 +2595,12 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
case sizeof (GFC_INTEGER_4):
buf4 = buf;
return swrite (dtp->u.p.current_unit->s, &buf4, len);
return swrite (dtp->u.p.current_unit->s, &buf4, &len);
break;
case sizeof (GFC_INTEGER_8):
buf8 = buf;
return swrite (dtp->u.p.current_unit->s, &buf8, len);
return swrite (dtp->u.p.current_unit->s, &buf8, &len);
break;
default:
......@@ -2569,13 +2615,13 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
case sizeof (GFC_INTEGER_4):
buf4 = buf;
reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
return swrite (dtp->u.p.current_unit->s, p, len);
return swrite (dtp->u.p.current_unit->s, p, &len);
break;
case sizeof (GFC_INTEGER_8):
buf8 = buf;
reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
return swrite (dtp->u.p.current_unit->s, p, len);
return swrite (dtp->u.p.current_unit->s, p, &len);
break;
default:
......@@ -2598,7 +2644,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* Bytes written. */
m = dtp->u.p.current_unit->recl_subrecord
- dtp->u.p.current_unit->bytes_left_subrecord;
c = stell (dtp->u.p.current_unit->s);
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. */
......@@ -2608,7 +2654,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
else
m_write = m;
if (unlikely (write_us_marker (dtp, m_write) < 0))
if (unlikely (write_us_marker (dtp, m_write) != 0))
goto io_error;
if (compile_options.record_marker == 0)
......@@ -2619,8 +2665,8 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* Seek to the head and overwrite the bogus length with the real
length. */
if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker,
SEEK_SET) < 0))
if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
== FAILURE))
goto io_error;
if (next_subrecord)
......@@ -2628,13 +2674,13 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
else
m_write = m;
if (unlikely (write_us_marker (dtp, m_write) < 0))
if (unlikely (write_us_marker (dtp, m_write) != 0))
goto io_error;
/* Seek past the end of the current record. */
if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker,
SEEK_SET) < 0))
if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker)
== FAILURE))
goto io_error;
return;
......@@ -2645,35 +2691,6 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
}
/* Utility function like memset() but operating on streams. Return
value is same as for POSIX write(). */
static ssize_t
sset (stream * s, int c, ssize_t nbyte)
{
static const int WRITE_CHUNK = 256;
char p[WRITE_CHUNK];
ssize_t bytes_left, trans;
if (nbyte < WRITE_CHUNK)
memset (p, c, nbyte);
else
memset (p, c, WRITE_CHUNK);
bytes_left = nbyte;
while (bytes_left > 0)
{
trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
trans = swrite (s, p, trans);
if (trans < 0)
return trans;
bytes_left -= trans;
}
return nbyte - bytes_left;
}
/* Position to the next record in write mode. */
static void
......@@ -2682,6 +2699,9 @@ next_record_w (st_parameter_dt *dtp, int done)
gfc_offset m, record, max_pos;
int length;
/* Flush and reset the format buffer. */
fbuf_flush (dtp->u.p.current_unit, 1);
/* Zero counters for X- and T-editing. */
max_pos = dtp->u.p.max_pos;
dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
......@@ -2696,11 +2716,8 @@ next_record_w (st_parameter_dt *dtp, int done)
if (dtp->u.p.current_unit->bytes_left == 0)
break;
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_flush (dtp->u.p.current_unit, WRITING);
if (sset (dtp->u.p.current_unit->s, ' ',
dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
dtp->u.p.current_unit->bytes_left) == FAILURE)
goto io_error;
break;
......@@ -2709,7 +2726,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (dtp->u.p.current_unit->bytes_left > 0)
{
length = (int) dtp->u.p.current_unit->bytes_left;
if (sset (dtp->u.p.current_unit->s, 0, length) != length)
if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE)
goto io_error;
}
break;
......@@ -2740,7 +2757,8 @@ next_record_w (st_parameter_dt *dtp, int done)
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
file_position (dtp->u.p.current_unit->s)
+ length) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
......@@ -2748,7 +2766,7 @@ next_record_w (st_parameter_dt *dtp, int done)
length = (int) (dtp->u.p.current_unit->recl - max_pos);
}
if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
......@@ -2764,7 +2782,7 @@ next_record_w (st_parameter_dt *dtp, int done)
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
......@@ -2787,7 +2805,8 @@ next_record_w (st_parameter_dt *dtp, int done)
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
file_position (dtp->u.p.current_unit->s)
+ length) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
......@@ -2798,7 +2817,7 @@ next_record_w (st_parameter_dt *dtp, int done)
length = (int) dtp->u.p.current_unit->bytes_left;
}
if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
......@@ -2807,27 +2826,23 @@ next_record_w (st_parameter_dt *dtp, int done)
}
else
{
size_t len;
const char crlf[] = "\r\n";
#ifdef HAVE_CRLF
const int len = 2;
len = 2;
#else
const int len = 1;
len = 1;
#endif
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
char * p = fbuf_alloc (dtp->u.p.current_unit, len);
if (!p)
if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
goto io_error;
#ifdef HAVE_CRLF
*(p++) = '\r';
#endif
*p = '\n';
if (is_stream_io (dtp))
{
dtp->u.p.current_unit->strm_pos += len;
if (dtp->u.p.current_unit->strm_pos
< file_length (dtp->u.p.current_unit->s))
unit_truncate (dtp->u.p.current_unit,
dtp->u.p.current_unit->strm_pos - 1,
&dtp->common);
struncate (dtp->u.p.current_unit->s);
}
}
......@@ -2865,7 +2880,7 @@ next_record (st_parameter_dt *dtp, int done)
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
fp = stell (dtp->u.p.current_unit->s);
fp = file_position (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
dtp->u.p.current_unit->last_record =
(fp + dtp->u.p.current_unit->recl - 1) /
......@@ -2877,8 +2892,6 @@ next_record (st_parameter_dt *dtp, int done)
if (!done)
pre_position (dtp);
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
}
......@@ -2927,6 +2940,7 @@ finalize_transfer (st_parameter_dt *dtp)
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
sfree (dtp->u.p.current_unit->s);
return;
}
......@@ -2941,9 +2955,10 @@ finalize_transfer (st_parameter_dt *dtp)
next_record (dtp, 1);
if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
&& stell (dtp->u.p.current_unit->s) >= dtp->rec)
&& file_position (dtp->u.p.current_unit->s) >= dtp->rec)
{
sflush (dtp->u.p.current_unit->s);
flush (dtp->u.p.current_unit->s);
sfree (dtp->u.p.current_unit->s);
}
return;
}
......@@ -2952,8 +2967,9 @@ finalize_transfer (st_parameter_dt *dtp)
if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
dtp->u.p.seen_dollar = 0;
fbuf_flush (dtp->u.p.current_unit, 1);
sfree (dtp->u.p.current_unit->s);
return;
}
......@@ -2965,17 +2981,15 @@ finalize_transfer (st_parameter_dt *dtp)
- dtp->u.p.current_unit->bytes_left);
dtp->u.p.current_unit->saved_pos =
dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
sflush (dtp->u.p.current_unit->s);
fbuf_flush (dtp->u.p.current_unit, 0);
flush (dtp->u.p.current_unit->s);
return;
}
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
next_record (dtp, 1);
sfree (dtp->u.p.current_unit->s);
}
/* Transfer function for IOLENGTH. It doesn't actually do any
......@@ -3032,6 +3046,8 @@ void
st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
{
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
free_mem (dtp->u.p.scratch);
library_end ();
}
......@@ -3047,6 +3063,29 @@ st_read (st_parameter_dt *dtp)
library_start (&dtp->common);
data_transfer_init (dtp, 1);
/* Handle complications dealing with the endfile record. */
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case NO_ENDFILE:
break;
case AT_ENDFILE:
if (!is_internal_unit (dtp))
{
generate_error (&dtp->common, LIBERROR_END, NULL);
dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
dtp->u.p.current_unit->current_record = 0;
}
break;
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
break;
}
}
extern void st_read_done (st_parameter_dt *);
......@@ -3058,6 +3097,8 @@ st_read_done (st_parameter_dt *dtp)
finalize_transfer (dtp);
free_format_data (dtp);
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
......@@ -3100,15 +3141,19 @@ st_write_done (st_parameter_dt *dtp)
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
if (!is_internal_unit (dtp))
unit_truncate (dtp->u.p.current_unit,
stell (dtp->u.p.current_unit->s),
&dtp->common);
{
flush (dtp->u.p.current_unit->s);
if (struncate (dtp->u.p.current_unit->s) == FAILURE)
generate_error (&dtp->common, LIBERROR_OS, NULL);
}
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
free_format_data (dtp);
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
......@@ -3222,46 +3267,3 @@ void reverse_memcpy (void *dest, const void *src, size_t n)
for (i=0; i<n; i++)
*(d++) = *(s--);
}
/* Once upon a time, a poor innocent Fortran program was reading a
file, when suddenly it hit the end-of-file (EOF). Unfortunately
the OS doesn't tell whether we're at the EOF or whether we already
went past it. Luckily our hero, libgfortran, keeps track of this.
Call this function when you detect an EOF condition. See Section
9.10.2 in F2003. */
void
hit_eof (st_parameter_dt * dtp)
{
dtp->u.p.current_unit->flags.position = POSITION_APPEND;
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case NO_ENDFILE:
case AT_ENDFILE:
generate_error (&dtp->common, LIBERROR_END, NULL);
if (!is_internal_unit (dtp))
{
dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
dtp->u.p.current_unit->current_record = 0;
}
else
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
break;
}
else
{
/* Non-sequential files don't have an ENDFILE record, so we
can't be at AFTER_ENDFILE. */
dtp->u.p.current_unit->endfile = AT_ENDFILE;
generate_error (&dtp->common, LIBERROR_END, NULL);
dtp->u.p.current_unit->current_record = 0;
}
}
libgfortran/io/unit.c
......@@ -541,8 +541,6 @@ init_units (void)
u->file = get_mem (u->file_len);
memmove (u->file, stdin_name, u->file_len);
fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
}
......@@ -699,62 +697,15 @@ close_units (void)
void
update_position (gfc_unit *u)
{
if (stell (u->s) == 0)
if (file_position (u->s) == 0)
u->flags.position = POSITION_REWIND;
else if (file_length (u->s) == stell (u->s))
else if (file_length (u->s) == file_position (u->s))
u->flags.position = POSITION_APPEND;
else
u->flags.position = POSITION_ASIS;
}
/* High level interface to truncate a file safely, i.e. flush format
buffers, check that it's a regular file, and generate error if that
occurs. Just like POSIX ftruncate, returns 0 on success, -1 on
failure. */
int
unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
{
int ret;
/* Make sure format buffer is flushed. */
if (u->flags.form == FORM_FORMATTED)
{
if (u->mode == READING)
pos += fbuf_reset (u);
else
fbuf_flush (u, u->mode);
}
/* Don't try to truncate a special file, just pretend that it
succeeds. */
if (is_special (u->s) || !is_seekable (u->s))
{
sflush (u->s);
return 0;
}
/* struncate() should flush the stream buffer if necessary, so don't
bother calling sflush() here. */
ret = struncate (u->s, pos);
if (ret != 0)
{
generate_error (common, LIBERROR_OS, NULL);
u->endfile = NO_ENDFILE;
u->flags.position = POSITION_ASIS;
}
else
{
u->endfile = AT_ENDFILE;
u->flags.position = POSITION_APPEND;
}
return ret;
}
/* filename_from_unit()-- If the unit_number exists, return a pointer to the
name of the associated file, otherwise return the empty string. The caller
must free memory allocated for the filename string. */
......@@ -795,25 +746,23 @@ finish_last_advance_record (gfc_unit *u)
{
if (u->saved_pos > 0)
fbuf_seek (u, u->saved_pos, SEEK_CUR);
fbuf_seek (u, u->saved_pos);
fbuf_flush (u, 1);
if (!(u->unit_number == options.stdout_unit
|| u->unit_number == options.stderr_unit))
{
size_t len;
const char crlf[] = "\r\n";
#ifdef HAVE_CRLF
const int len = 2;
len = 2;
#else
const int len = 1;
len = 1;
#endif
char *p = fbuf_alloc (u, len);
if (!p)
if (swrite (u->s, &crlf[2-len], &len) != 0)
os_error ("Completing record after ADVANCE_NO failed");
#ifdef HAVE_CRLF
*(p++) = '\r';
#endif
*p = '\n';
}
fbuf_flush (u, u->mode);
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment