This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch,libgfortran] PR37754 [4.4 Regression] READ I/O Performance regression from 4.3 to 4.4
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Cc: Patches <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 25 Dec 2008 09:32:57 -0800
- Subject: [patch,libgfortran] PR37754 [4.4 Regression] READ I/O Performance regression from 4.3 to 4.4
This is a Merry Christmas patch.
This patch recovers the performance from this regression by creating a stream
read_char function which is simply a trimmed down version of sread (fd_read). I
was actually surprised when I saw the test results. I suspect that the
simplification allows some better optimizations.
The patch also refactors next_char in list_read.c to eliminate goto's and
inlining a small portion of the "done:" code. The refactoring of next_char
alone gains 2.8% over current trunk. The use of the new read_char function
gains significant additional performance.
Using the countlines.f test case in the PR for comparison, average 5 runs.
gfortran 4.3: 3.357 seconds
gfortran 4.4 current trunk: 3.821 seconds
gfortran 4.4 patched: 3.164 seconds
This is a 5.7% improvement over 4.3 for this test case and 17% improvement over
current trunk.
I also believe this refactoring will make for some easier further improvements.
I don't know the status of Janne's patch so this patch may end up being short
lived. However, it is not very intrusive in the sense that it is mostly
reorganizing in simple ways our existing code paths. Since it involves a
regression, I think it would be OK for 4.4
Regression tested on x86-64.
OK to commit?
Jerry
2008-12-25 Jerry DeLisle
PR libgfortran/37754
* io/list_read.c (next_char): Factor out code for handling internal
units into a new function called next_char_iunit. Inline the code after
done and eliminate all goto's. Replace call to sread with new function
called sread_char. Move the incrementing of strm_pos to the end of the
function and get rid of the conditional.
(next_char_iunit): New function.
* io.h (stream): Add new function pointer, read_char, to structure.
Define new sread_char macro to call this function.
* unix.c (fd_read_char): Add this new function which is simply a
trimmed down version of fd_read. (fd_open): Set read_char pointer to
new function fd_read. (open_internal): Set read_char pointer
mem_read.
* transfer.c (formatted transfer_scalar): Remove this function by
factoring it into two new functions, one for read and one for right,
eliminating all the conditionals for read or write mode.
(formatted transfer_scalar_read): New function.
(formatted transfer_scalar_write): New function.
* write_float.def (output_float_FMT_G_): Update this macro to further
simplify the calculation of temp.
Index: list_read.c
===================================================================
--- list_read.c (revision 142883)
+++ list_read.c (working copy)
@@ -138,38 +138,12 @@ free_line (st_parameter_dt *dtp)
static char
-next_char (st_parameter_dt *dtp)
+next_char_iunit (st_parameter_dt *dtp)
{
size_t length;
gfc_offset record;
char c;
- if (dtp->u.p.last_char != '\0')
- {
- dtp->u.p.at_eol = 0;
- c = dtp->u.p.last_char;
- dtp->u.p.last_char = '\0';
- goto done;
- }
-
- /* Read from line_buffer if enabled. */
-
- if (dtp->u.p.line_buffer_enabled)
- {
- dtp->u.p.at_eol = 0;
-
- c = dtp->u.p.line_buffer[dtp->u.p.item_count];
- if (c != '\0' && dtp->u.p.item_count < 64)
- {
- dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
- dtp->u.p.item_count++;
- goto done;
- }
-
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 0;
- }
-
/* Handle the end-of-record and end-of-file conditions for
internal array unit. */
if (is_array_io (dtp))
@@ -190,7 +164,8 @@ next_char (st_parameter_dt *dtp)
if (finished)
{
dtp->u.p.at_eof = 1;
- goto done;
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ return c;
}
record *= dtp->u.p.current_unit->recl;
@@ -198,7 +173,8 @@ next_char (st_parameter_dt *dtp)
longjmp (*dtp->u.p.eof_jump, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
- goto done;
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ return c;
}
}
@@ -212,43 +188,80 @@ next_char (st_parameter_dt *dtp)
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))
+ dtp->u.p.current_unit->bytes_left--;
+ else
{
- if (is_array_io (dtp))
- {
- /* Check whether we hit EOF. */
- if (length == 0)
- {
- generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
- return '\0';
- }
- dtp->u.p.current_unit->bytes_left--;
- }
- else
+ if (dtp->u.p.at_eof)
+ longjmp (*dtp->u.p.eof_jump, 1);
+ if (length == 0)
{
- if (dtp->u.p.at_eof)
- longjmp (*dtp->u.p.eof_jump, 1);
- if (length == 0)
- {
- c = '\n';
- dtp->u.p.at_eof = 1;
- }
+ c = '\n';
+ dtp->u.p.at_eof = 1;
}
}
- else
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ return c;
+}
+
+
+static char
+next_char (st_parameter_dt *dtp)
+{
+ size_t length;
+ char c;
+
+ if (dtp->u.p.last_char != '\0')
{
- if (length == 0)
+ dtp->u.p.at_eol = 0;
+ c = dtp->u.p.last_char;
+ dtp->u.p.last_char = '\0';
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ return c;
+ }
+
+ /* Read from line_buffer if enabled. */
+
+ if (dtp->u.p.line_buffer_enabled)
+ {
+ dtp->u.p.at_eol = 0;
+
+ c = dtp->u.p.line_buffer[dtp->u.p.item_count];
+ if (c != '\0' && dtp->u.p.item_count < 64)
{
- 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';
+ dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
+ dtp->u.p.item_count++;
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ return c;
}
+
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+ }
+
+ /* Handle the end-of-record and end-of-file conditions for
+ internal array unit. */
+ if (is_internal_unit (dtp))
+ return next_char_iunit (dtp);
+
+ /* Get the next character and handle end-of-record conditions. */
+
+ length = 1;
+
+ if (sread_char (dtp->u.p.current_unit->s, &c, &length) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return '\0';
+ }
+
+ 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';
}
-done:
+ dtp->u.p.current_unit->strm_pos++;
dtp->u.p.at_eol = (c == '\n' || c == '\r');
return c;
}
Index: io.h
===================================================================
--- io.h (revision 142883)
+++ io.h (working copy)
@@ -55,6 +55,7 @@ typedef struct stream
try (*seek) (struct stream *, gfc_offset);
try (*trunc) (struct stream *);
int (*read) (struct stream *, void *, size_t *);
+ int (*read_char) (struct stream *, void *, size_t *);
int (*write) (struct stream *, const void *, size_t *);
try (*set) (struct stream *, int, size_t);
}
@@ -74,6 +75,7 @@ io_mode;
#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 sread_char(s, buf, nbytes) ((s)->read_char)(s, buf, nbytes)
#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
#define sset(s, c, n) ((s)->set)(s, c, n)
Index: unix.c
===================================================================
--- unix.c (revision 142883)
+++ unix.c (working copy)
@@ -761,6 +761,28 @@ fd_sset (unix_stream * s, int c, size_t
}
+static int
+fd_read_char (unix_stream * s, char *c, size_t * nbytes)
+{
+ char *p;
+ int tmp;
+
+ tmp = 1;
+ p = (char *) fd_alloc_r_at (s, &tmp);
+ if (p)
+ {
+ *nbytes = tmp;
+ *c = *p;
+ return 0;
+ }
+ else
+ {
+ *nbytes = 0;
+ return errno;
+ }
+}
+
+
/* Stream read function. Avoids using a buffer for big reads. The
interface is like POSIX read(), but the nbytes argument is a
pointer; on return it contains the number of bytes written. The
@@ -892,6 +914,7 @@ fd_open (unix_stream * s)
s->st.seek = (void *) fd_seek;
s->st.trunc = (void *) fd_truncate;
s->st.read = (void *) fd_read;
+ s->st.read_char = (void *) fd_read_char;
s->st.write = (void *) fd_write;
s->st.set = (void *) fd_sset;
@@ -1097,6 +1120,7 @@ open_internal (char *base, int length, g
s->st.seek = (void *) mem_seek;
s->st.trunc = (void *) mem_truncate;
s->st.read = (void *) mem_read;
+ s->st.read_char = (void *) mem_read;
s->st.write = (void *) mem_write;
s->st.set = (void *) mem_set;
Index: transfer.c
===================================================================
--- transfer.c (revision 142883)
+++ transfer.c (working copy)
@@ -929,8 +929,8 @@ require_type (st_parameter_dt *dtp, bt e
of the next element, then comes back here to process it. */
static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
- size_t size)
+formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p,
+ int kind, size_t size)
{
char scratch[SCRATCH_SIZE];
int pos, bytes_used;
@@ -1026,166 +1026,103 @@ formatted_transfer_scalar (st_parameter_
{
case FMT_I:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_decimal (dtp, f, p, kind);
- else
- write_i (dtp, f, p, kind);
-
+ read_decimal (dtp, f, p, kind);
break;
case FMT_B:
if (n == 0)
- goto need_data;
-
+ goto need_data_read;
if (compile_options.allow_std < GFC_STD_GNU
&& require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 2);
- else
- write_b (dtp, f, p, kind);
-
+ read_radix (dtp, f, p, kind, 2);
break;
case FMT_O:
if (n == 0)
- goto need_data;
-
+ goto need_data_read;
if (compile_options.allow_std < GFC_STD_GNU
&& require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 8);
- else
- write_o (dtp, f, p, kind);
-
+ read_radix (dtp, f, p, kind, 8);
break;
case FMT_Z:
if (n == 0)
- goto need_data;
-
+ goto need_data_read;
if (compile_options.allow_std < GFC_STD_GNU
&& require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 16);
- else
- write_z (dtp, f, p, kind);
-
+ read_radix (dtp, f, p, kind, 16);
break;
case FMT_A:
if (n == 0)
- goto need_data;
+ goto need_data_read;
/* It is possible to have FMT_A with something not BT_CHARACTER such
as when writing out hollerith strings, so check both type
and kind before calling wide character routines. */
- if (dtp->u.p.mode == READING)
- {
- if (type == BT_CHARACTER && kind == 4)
- read_a_char4 (dtp, f, p, size);
- else
- read_a (dtp, f, p, size);
- }
+ if (type == BT_CHARACTER && kind == 4)
+ read_a_char4 (dtp, f, p, size);
else
- {
- if (type == BT_CHARACTER && kind == 4)
- write_a_char4 (dtp, f, p, size);
- else
- write_a (dtp, f, p, size);
- }
+ read_a (dtp, f, p, size);
break;
case FMT_L:
if (n == 0)
- goto need_data;
-
- if (dtp->u.p.mode == READING)
- read_l (dtp, f, p, kind);
- else
- write_l (dtp, f, p, kind);
-
+ goto need_data_read;
+ read_l (dtp, f, p, kind);
break;
case FMT_D:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_d (dtp, f, p, kind);
-
+ read_f (dtp, f, p, kind);
break;
case FMT_E:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_e (dtp, f, p, kind);
+ read_f (dtp, f, p, kind);
break;
case FMT_EN:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_en (dtp, f, p, kind);
-
+ read_f (dtp, f, p, kind);
break;
case FMT_ES:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_es (dtp, f, p, kind);
-
+ read_f (dtp, f, p, kind);
break;
case FMT_F:
if (n == 0)
- goto need_data;
+ goto need_data_read;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_f (dtp, f, p, kind);
-
+ read_f (dtp, f, p, kind);
break;
case FMT_G:
if (n == 0)
- goto need_data;
- if (dtp->u.p.mode == READING)
- switch (type)
- {
+ goto need_data_read;
+ switch (type)
+ {
case BT_INTEGER:
read_decimal (dtp, f, p, kind);
break;
@@ -1202,9 +1139,388 @@ formatted_transfer_scalar (st_parameter_
read_f (dtp, f, p, kind);
break;
default:
- goto bad_type;
- }
+ internal_error (&dtp->common,
+ "formatted_transfer(): Bad type");
+ }
+ break;
+
+ case FMT_STRING:
+ consume_data_flag = 0;
+ format_error (dtp, f, "Constant string in input format");
+ return;
+
+ /* Format codes that don't transfer data. */
+ case FMT_X:
+ case FMT_TR:
+ consume_data_flag = 0;
+
+ 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;
+
+ read_x (dtp, f->u.n);
+ break;
+
+ case FMT_TL:
+ case FMT_T:
+ consume_data_flag = 0;
+
+ if (f->format == FMT_TL)
+ {
+
+ /* Handle the special case when no bytes have been used yet.
+ Cannot go below zero. */
+ if (bytes_used == 0)
+ {
+ dtp->u.p.pending_spaces -= f->u.n;
+ dtp->u.p.skips -= f->u.n;
+ dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
+ }
+
+ pos = bytes_used - f->u.n;
+ }
+ else /* FMT_T */
+ pos = f->u.n - 1;
+
+ /* Standard 10.6.1.1: excessive left tabbing is reset to the
+ left tab limit. We do not check if the position has gone
+ beyond the end of record because a subsequent tab could
+ bring us back again. */
+ pos = pos < 0 ? 0 : pos;
+
+ dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ + pos - dtp->u.p.max_pos;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+ ? 0 : dtp->u.p.pending_spaces;
+
+ if (dtp->u.p.skips == 0)
+ break;
+
+ /* Writes occur just before the switch on f->format, above, so that
+ trailing blanks are suppressed. Adjust everything for
+ end-of-record condition */
+ if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
+ {
+ 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)
+ {
+ move_pos_offset (dtp->u.p.current_unit->s, 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;
+ }
+ else
+ read_x (dtp, dtp->u.p.skips);
+ break;
+
+ case FMT_S:
+ consume_data_flag = 0;
+ dtp->u.p.sign_status = SIGN_S;
+ break;
+
+ case FMT_SS:
+ consume_data_flag = 0;
+ dtp->u.p.sign_status = SIGN_SS;
+ break;
+
+ case FMT_SP:
+ consume_data_flag = 0;
+ dtp->u.p.sign_status = SIGN_SP;
+ break;
+
+ case FMT_BN:
+ consume_data_flag = 0 ;
+ dtp->u.p.blank_status = BLANK_NULL;
+ break;
+
+ case FMT_BZ:
+ consume_data_flag = 0;
+ dtp->u.p.blank_status = BLANK_ZERO;
+ break;
+
+ case FMT_DC:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
+ break;
+
+ case FMT_DP:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
+ break;
+
+ case FMT_P:
+ consume_data_flag = 0;
+ dtp->u.p.scale_factor = f->u.k;
+ break;
+
+ case FMT_DOLLAR:
+ consume_data_flag = 0;
+ dtp->u.p.seen_dollar = 1;
+ break;
+
+ case FMT_SLASH:
+ consume_data_flag = 0;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ next_record (dtp, 0);
+ break;
+
+ case FMT_COLON:
+ /* A colon descriptor causes us to exit this loop (in
+ particular preventing another / descriptor from being
+ processed) unless there is another data item to be
+ transferred. */
+ consume_data_flag = 0;
+ if (n == 0)
+ return;
+ break;
+
+ default:
+ 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))
+ {
+ n--;
+ p = ((char *) p) + size;
+ }
+
+ dtp->u.p.skips = 0;
+
+ pos = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
+
+ } /* End for. */
+
+ return;
+
+ /* Come here when we need a data descriptor but don't have one. We
+ push the current format node back onto the input, then return and
+ let the user program call us back with the data. */
+ need_data_read:
+ unget_format (dtp, f);
+}
+
+static void
+formatted_transfer_scalar_write (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;
+ int n;
+ int consume_data_flag;
+
+ /* Change a complex data item into a pair of reals. */
+
+ n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
+ if (type == BT_COMPLEX)
+ {
+ type = BT_REAL;
+ size /= 2;
+ }
+
+ /* If there's an EOR condition, we simulate finalizing the transfer
+ by doing nothing. */
+ if (dtp->u.p.eor_condition)
+ return;
+
+ /* Set this flag so that commas in reads cause the read to complete before
+ the entire field has been read. The next read field will start right after
+ the comma in the stream. (Set to 0 for character reads). */
+ 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,
+ then we have to move to the next record. */
+ if (dtp->u.p.reversion_flag && n > 0)
+ {
+ dtp->u.p.reversion_flag = 0;
+ next_record (dtp, 0);
+ }
+
+ consume_data_flag = 1;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ break;
+
+ f = next_format (dtp);
+ if (f == NULL)
+ {
+ /* No data descriptors left. */
+ if (unlikely (n > 0))
+ generate_error (&dtp->common, LIBERROR_FORMAT,
+ "Insufficient data descriptors in format after reversion");
+ return;
+ }
+
+ /* Now discharge T, TR and X movements to the right. This is delayed
+ until a data producing format to suppress trailing spaces. */
+
+ t = f->format;
+ if (dtp->u.p.skips != 0
+ && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
+ || t == FMT_Z || t == FMT_F || t == FMT_E
+ || t == FMT_EN || t == FMT_ES || t == FMT_G
+ || t == FMT_L || t == FMT_A || t == FMT_D))
+ || t == FMT_STRING))
+ {
+ if (dtp->u.p.skips > 0)
+ {
+ int tmp;
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ tmp = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.max_pos =
+ dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
+ }
+ 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);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
+ }
+ 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);
+
+ if (is_stream_io(dtp))
+ bytes_used = 0;
+
+ switch (t)
+ {
+ case FMT_I:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_INTEGER, type, f))
+ return;
+ write_i (dtp, f, p, kind);
+ break;
+
+ case FMT_B:
+ if (n == 0)
+ goto need_data_write;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ write_b (dtp, f, p, kind);
+ break;
+
+ case FMT_O:
+ if (n == 0)
+ goto need_data_write;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ write_o (dtp, f, p, kind);
+ break;
+
+ case FMT_Z:
+ if (n == 0)
+ goto need_data_write;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ write_z (dtp, f, p, kind);
+ break;
+
+ case FMT_A:
+ if (n == 0)
+ goto need_data_write;
+
+ /* It is possible to have FMT_A with something not BT_CHARACTER such
+ as when writing out hollerith strings, so check both type
+ and kind before calling wide character routines. */
+ if (type == BT_CHARACTER && kind == 4)
+ write_a_char4 (dtp, f, p, size);
else
+ write_a (dtp, f, p, size);
+ break;
+
+ case FMT_L:
+ if (n == 0)
+ goto need_data_write;
+ write_l (dtp, f, p, kind);
+ break;
+
+ case FMT_D:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_d (dtp, f, p, kind);
+ break;
+
+ case FMT_E:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_e (dtp, f, p, kind);
+ break;
+
+ case FMT_EN:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_en (dtp, f, p, kind);
+ break;
+
+ case FMT_ES:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_es (dtp, f, p, kind);
+ break;
+
+ case FMT_F:
+ if (n == 0)
+ goto need_data_write;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_f (dtp, f, p, kind);
+ break;
+
+ case FMT_G:
+ if (n == 0)
+ goto need_data_write;
+
switch (type)
{
case BT_INTEGER:
@@ -1226,20 +1542,13 @@ formatted_transfer_scalar (st_parameter_
write_d (dtp, f, p, kind);
break;
default:
- bad_type:
internal_error (&dtp->common,
"formatted_transfer(): Bad type");
}
-
break;
case FMT_STRING:
consume_data_flag = 0;
- if (dtp->u.p.mode == READING)
- {
- format_error (dtp, f, "Constant string in input format");
- return;
- }
write_constant_string (dtp, f);
break;
@@ -1256,16 +1565,11 @@ formatted_transfer_scalar (st_parameter_
that trailing blanks are suppressed, unless we are doing a
non-advancing write in which case we want to output the blanks
now. */
- if (dtp->u.p.mode == WRITING
- && dtp->u.p.advance_status == ADVANCE_NO)
+ if (dtp->u.p.advance_status == ADVANCE_NO)
{
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
-
- if (dtp->u.p.mode == READING)
- read_x (dtp, f->u.n);
-
break;
case FMT_TL:
@@ -1287,12 +1591,7 @@ formatted_transfer_scalar (st_parameter_
pos = bytes_used - f->u.n;
}
else /* FMT_T */
- {
- if (dtp->u.p.mode == READING)
- pos = f->u.n - 1;
- else
- pos = f->u.n - dtp->u.p.pending_spaces - 1;
- }
+ pos = f->u.n - dtp->u.p.pending_spaces - 1;
/* Standard 10.6.1.1: excessive left tabbing is reset to the
left tab limit. We do not check if the position has gone
@@ -1306,42 +1605,6 @@ formatted_transfer_scalar (st_parameter_
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
? 0 : dtp->u.p.pending_spaces;
- if (dtp->u.p.skips == 0)
- break;
-
- /* Writes occur just before the switch on f->format, above, so that
- trailing blanks are suppressed. */
- if (dtp->u.p.mode == READING)
- {
- /* Adjust everything for end-of-record condition */
- if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
- {
- 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)
- {
- move_pos_offset (dtp->u.p.current_unit->s, 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;
- }
- else
- read_x (dtp, dtp->u.p.skips);
- }
-
break;
case FMT_S:
@@ -1433,14 +1696,14 @@ formatted_transfer_scalar (st_parameter_
pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
- }
+ } /* End for. */
return;
/* Come here when we need a data descriptor but don't have one. We
push the current format node back onto the input, then return and
let the user program call us back with the data. */
- need_data:
+ need_data_write:
unget_format (dtp, f);
}
@@ -1455,10 +1718,23 @@ formatted_transfer (st_parameter_dt *dtp
size_t stride = type == BT_CHARACTER ?
size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
/* Big loop over all the elements. */
- for (elem = 0; elem < nelems; elem++)
+ if (dtp->u.p.mode == READING)
{
- dtp->u.p.item_count++;
- formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
+ for (elem = 0; elem < nelems; elem++)
+ {
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar_read (dtp, type, tmp + stride*elem,
+ kind, size);
+ }
+ }
+ else
+ {
+ for (elem = 0; elem < nelems; elem++)
+ {
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar_write (dtp, type, tmp + stride*elem,
+ kind, size);
+ }
}
}
Index: write_float.def
===================================================================
--- write_float.def (revision 142884)
+++ write_float.def (working copy)
@@ -640,8 +640,8 @@ output_float_FMT_G_ ## x (st_parameter_d
GFC_REAL_ ## x temp;\
mid = (low + high) / 2;\
\
- temp = (calculate_exp_ ## x (mid) - \
- 5 * calculate_exp_ ## x (mid - d - 1)) / 10;\
+ temp = calculate_exp_ ## x (mid - 1) * \
+ (1 - 1/(2 * exp_d));\
\
if (m < temp)\
{ \