From 17716b74d77eda5c4bc28b5dae0a94ab5f0a95f7 Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 14 Jul 2005 06:21:59 +0000
Subject: [PATCH] 2005-07-12 Paul Thomas <pault@gcc.gnu.org>
PR libfortran/16435
* transfer.c (formatted_transfer): Correct the problems
with X- and T-editting that caused TLs followed by TRs
to overwrite data, which caused NIST FM908.FOR to fail
on many tests.
(data_transfer_init): Zero X- and T-editting counters at
the start of formatted IO.
* write.c (write_x): Write specified number of skips with
specified number of spaces at the end.
2005-07-12 Paul Thomas <pault@gcc.gnu.org>
PR libfortran/16435
* gfortran.dg/tl_editting.f90: New.
* gfortran.dg/g77/f77-edit-x-out.f: Remove XFAIL.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@102008 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/testsuite/ChangeLog | 6 +
.../gfortran.dg/g77/f77-edit-x-out.f | 2 +-
gcc/testsuite/gfortran.dg/tl_editing.f90 | 13 +
libgfortran/ChangeLog | 12 +
libgfortran/io/io.h | 2 +-
libgfortran/io/transfer.c | 271 ++++++++++--------
libgfortran/io/write.c | 7 +-
7 files changed, 195 insertions(+), 118 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/tl_editing.f90
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1c94063bc1bd..b3585c7d75ba 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2005-07-12 Paul Thomas <pault@gcc.gnu.org>
+
+ PR libfortran/16435
+ * gfortran.dg/tl_editting.f90: New.
+ * gfortran.dg/g77/f77-edit-x-out.f: Remove XFAIL.
+
2005-07-14 Steven G. Kargl <kargls@comcast.net>
* gfortran.dg/char_array_constructor.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f b/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f
index 400b85b6bf1a..9d196331dd16 100644
--- a/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f
+++ b/gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f
@@ -8,5 +8,5 @@ C ( dg-output "^" }
write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
C Section 13.5.3 explains why there are no trailing blanks
write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
-C { dg-output "\$" {xfail *-*-*} } gfortran PR 16435
+C { dg-output "\$" }
end
diff --git a/gcc/testsuite/gfortran.dg/tl_editing.f90 b/gcc/testsuite/gfortran.dg/tl_editing.f90
new file mode 100644
index 000000000000..3a313cd2b591
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/tl_editing.f90
@@ -0,0 +1,13 @@
+! { dg-do run }
+! Test of fix to bug triggered by NIST fm908.for.
+! Left tabbing, followed by X or T-tabbing to the right would
+! cause spaces to be overwritten on output data.
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ program tl_editting
+ character*10 :: line
+ character*10 :: aline = "abcdefxyij"
+ character*2 :: bline = "gh"
+ character*10 :: cline = "abcdefghij"
+ write (line, '(a10,tl6,2x,a2)') aline, bline
+ if (line.ne.cline) call abort ()
+ end program tl_editting
\ No newline at end of file
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 25f55c7398a1..48788f197cb9 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,15 @@
+2005-07-12 Paul Thomas <pault@gcc.gnu.org>
+
+ PR libfortran/16435
+ * transfer.c (formatted_transfer): Correct the problems
+ with X- and T-editting that caused TLs followed by TRs
+ to overwrite data, which caused NIST FM908.FOR to fail
+ on many tests.
+ (data_transfer_init): Zero X- and T-editting counters at
+ the start of formatted IO.
+ * write.c (write_x): Write specified number of skips with
+ specified number of spaces at the end.
+
2005-07-13 Paul Thomas <pault@gcc.gnu.org>
* io/read.c (read_complex): Prevent X formatting during reads
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index a301682a62c8..37bdb3ebdfac 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -638,7 +638,7 @@ internal_proto(write_l);
extern void write_o (fnode *, const char *, int);
internal_proto(write_o);
-extern void write_x (fnode *);
+extern void write_x (int, int);
internal_proto(write_x);
extern void write_z (fnode *, const char *, int);
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index bcba218c50ad..161e5cca4020 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -82,6 +82,13 @@ gfc_unit *current_unit = NULL;
static int sf_seen_eor = 0;
static int eor_condition = 0;
+/* Maximum righthand column written to. */
+static int max_pos;
+/* Number of skips + spaces to be done for T and X-editing. */
+static int skips;
+/* Number of spaces to be done for T and X-editing. */
+static int pending_spaces;
+
char scratch[SCRATCH_SIZE];
static char *line_buffer = NULL;
@@ -166,11 +173,11 @@ read_sf (int *length)
do
{
if (is_internal_unit())
- {
+ {
/* readlen may be modified inside salloc_r if
is_internal_unit() is true. */
- readlen = 1;
- }
+ readlen = 1;
+ }
q = salloc_r (current_unit->s, &readlen);
if (q == NULL)
@@ -204,7 +211,7 @@ read_sf (int *length)
current_unit->bytes_left = 0;
*length = n;
- sf_seen_eor = 1;
+ sf_seen_eor = 1;
break;
}
@@ -437,8 +444,9 @@ require_type (bt expected, bt actual, fnode * f)
static void
formatted_transfer (bt type, void *p, int len)
{
- int pos ,m ;
+ int pos;
fnode *f;
+ format_token t;
int n;
int consume_data_flag;
@@ -456,12 +464,12 @@ formatted_transfer (bt type, void *p, int len)
for (;;)
{
/* If reversion has occurred and there is another real data item,
- then we have to move to the next record. */
+ then we have to move to the next record. */
if (g.reversion_flag && n > 0)
- {
- g.reversion_flag = 0;
- next_record (0);
- }
+ {
+ g.reversion_flag = 0;
+ next_record (0);
+ }
consume_data_flag = 1 ;
if (ioparm.library_return != LIBRARY_OK)
@@ -469,9 +477,23 @@ formatted_transfer (bt type, void *p, int len)
f = next_format ();
if (f == NULL)
- return; /* No data descriptors left (already raised). */
+ return; /* No data descriptors left (already raised). */
+
+ /* Now discharge T, TR and X movements to the right. This is delayed
+ until a data producing format to supress trailing spaces. */
+ t = f->format;
+ if (g.mode == WRITING && skips > 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))
+ {
+ write_x (skips, pending_spaces);
+ max_pos = current_unit->recl - current_unit->bytes_left;
+ skips = pending_spaces = 0;
+ }
- switch (f->format)
+ switch (t)
{
case FMT_I:
if (n == 0)
@@ -651,7 +673,7 @@ formatted_transfer (bt type, void *p, int len)
break;
case FMT_STRING:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
if (g.mode == READING)
{
format_error (f, "Constant string in input format");
@@ -660,90 +682,100 @@ formatted_transfer (bt type, void *p, int len)
write_constant_string (f);
break;
- /* Format codes that don't transfer data. */
+ /* Format codes that don't transfer data. */
case FMT_X:
case FMT_TR:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
+
+ pos = current_unit->recl - current_unit->bytes_left + f->u.n;
+ skips = f->u.n;
+ pending_spaces = pos - max_pos;
+
+ /* Writes occur just before the switch on f->format, above, so that
+ trailing blanks are suppressed. */
if (g.mode == READING)
read_x (f);
- else
- write_x (f);
break;
- case FMT_TL:
- case FMT_T:
- if (f->format == FMT_TL)
- pos = current_unit->recl - current_unit->bytes_left - f->u.n;
- else /* FMT_T */
- {
- consume_data_flag = 0;
- pos = f->u.n - 1;
- }
-
- if (pos < 0 || pos >= current_unit->recl )
- {
- generate_error (ERROR_EOR, "T or TL edit position error");
- break ;
- }
- m = pos - (current_unit->recl - current_unit->bytes_left);
-
- if (m == 0)
- break;
-
- if (m > 0)
- {
- f->u.n = m;
- if (g.mode == READING)
- read_x (f);
- else
- write_x (f);
- }
- if (m < 0)
- {
- move_pos_offset (current_unit->s,m);
- current_unit->bytes_left -= m;
- }
+ case FMT_TL:
+ case FMT_T:
+ if (f->format == FMT_TL)
+ pos = current_unit->recl - current_unit->bytes_left - f->u.n;
+ else /* FMT_T */
+ {
+ consume_data_flag = 0;
+ 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;
+
+ skips = skips + pos - (current_unit->recl - current_unit->bytes_left);
+ pending_spaces = pending_spaces + pos - max_pos;
+
+ if (skips == 0)
+ break;
+
+ /* Writes occur just before the switch on f->format, above, so that
+ trailing blanks are suppressed. */
+ if (skips > 0)
+ {
+ if (g.mode == READING)
+ {
+ f->u.n = skips;
+ read_x (f);
+ }
+ }
+ if (skips < 0)
+ {
+ move_pos_offset (current_unit->s, skips);
+ current_unit->bytes_left -= skips;
+ skips = pending_spaces = 0;
+ }
break;
case FMT_S:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.sign_status = SIGN_S;
break;
case FMT_SS:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.sign_status = SIGN_SS;
break;
case FMT_SP:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.sign_status = SIGN_SP;
break;
case FMT_BN:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.blank_status = BLANK_NULL;
break;
case FMT_BZ:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.blank_status = BLANK_ZERO;
break;
case FMT_P:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
g.seen_dollar = 1;
break;
case FMT_SLASH:
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
next_record (0);
break;
@@ -752,7 +784,7 @@ formatted_transfer (bt type, void *p, int len)
particular preventing another / descriptor from being
processed) unless there is another data item to be
transferred. */
- consume_data_flag = 0 ;
+ consume_data_flag = 0 ;
if (n == 0)
return;
break;
@@ -776,8 +808,15 @@ formatted_transfer (bt type, void *p, int len)
if ((consume_data_flag > 0) && (n > 0))
{
n--;
- p = ((char *) p) + len;
+ p = ((char *) p) + len;
}
+
+ if (g.mode == READING)
+ skips = 0;
+
+ pos = current_unit->recl - current_unit->bytes_left;
+ max_pos = (max_pos > pos) ? max_pos : pos;
+
}
return;
@@ -977,7 +1016,7 @@ data_transfer_init (int read_flag)
{
current_unit->recl = file_length(current_unit->s);
if (g.mode==WRITING)
- empty_internal_buffer (current_unit->s);
+ empty_internal_buffer (current_unit->s);
}
/* Check the action. */
@@ -1007,14 +1046,14 @@ data_transfer_init (int read_flag)
if (ioparm.namelist_name != NULL && ionml != NULL)
{
- if(ioparm.format != NULL)
- generate_error (ERROR_OPTION_CONFLICT,
- "A format cannot be specified with a namelist");
+ if(ioparm.format != NULL)
+ generate_error (ERROR_OPTION_CONFLICT,
+ "A format cannot be specified with a namelist");
}
else if (current_unit->flags.form == FORM_FORMATTED &&
- ioparm.format == NULL && !ioparm.list_format)
+ ioparm.format == NULL && !ioparm.list_format)
generate_error (ERROR_OPTION_CONFLICT,
- "Missing format for FORMATTED data transfer");
+ "Missing format for FORMATTED data transfer");
if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
@@ -1108,11 +1147,11 @@ data_transfer_init (int read_flag)
/* Check to see if we might be reading what we wrote before */
if (g.mode == READING && current_unit->mode == WRITING)
- flush(current_unit->s);
+ flush(current_unit->s);
/* Position the file. */
if (sseek (current_unit->s,
- (ioparm.rec - 1) * current_unit->recl) == FAILURE)
+ (ioparm.rec - 1) * current_unit->recl) == FAILURE)
generate_error (ERROR_OS, NULL);
}
@@ -1121,7 +1160,7 @@ data_transfer_init (int read_flag)
if (g.mode == WRITING
&& current_unit->flags.access == ACCESS_SEQUENTIAL
&& current_unit->current_record == 0)
- struncate(current_unit->s);
+ struncate(current_unit->s);
current_unit->mode = g.mode;
@@ -1147,10 +1186,10 @@ data_transfer_init (int read_flag)
else
{
if (ioparm.list_format)
- {
- transfer = list_formatted_read;
- init_at_eol();
- }
+ {
+ transfer = list_formatted_read;
+ init_at_eol();
+ }
else
transfer = formatted_transfer;
}
@@ -1185,6 +1224,10 @@ data_transfer_init (int read_flag)
current_unit->read_bad = 1;
}
+ /* Reset counters for T and X-editing. */
+ if (current_unit->flags.form == FORM_FORMATTED)
+ max_pos = skips = pending_spaces = 0;
+
/* Start the data transfer if we are doing a formatted transfer. */
if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
&& ioparm.namelist_name == NULL && ionml == NULL)
@@ -1256,27 +1299,27 @@ next_record_r (void)
}
do
- {
- p = salloc_r (current_unit->s, &length);
-
- /* In case of internal file, there may not be any '\n'. */
- if (is_internal_unit() && p == NULL)
- {
- break;
- }
-
- if (p == NULL)
- {
- generate_error (ERROR_OS, NULL);
- break;
- }
-
- if (length == 0)
- {
- current_unit->endfile = AT_ENDFILE;
- break;
- }
- }
+ {
+ p = salloc_r (current_unit->s, &length);
+
+ /* In case of internal file, there may not be any '\n'. */
+ if (is_internal_unit() && p == NULL)
+ {
+ break;
+ }
+
+ if (p == NULL)
+ {
+ generate_error (ERROR_OS, NULL);
+ break;
+ }
+
+ if (length == 0)
+ {
+ current_unit->endfile = AT_ENDFILE;
+ break;
+ }
+ }
while (*p != '\n');
break;
@@ -1315,7 +1358,7 @@ next_record_w (void)
case UNFORMATTED_DIRECT:
if (sfree (current_unit->s) == FAILURE)
- goto io_error;
+ goto io_error;
break;
case UNFORMATTED_SEQUENTIAL:
@@ -1357,12 +1400,12 @@ next_record_w (void)
p = salloc_w (current_unit->s, &length);
if (!is_internal_unit())
- {
- if (p)
- *p = '\n'; /* No CR for internal writes. */
- else
- goto io_error;
- }
+ {
+ if (p)
+ *p = '\n'; /* No CR for internal writes. */
+ else
+ goto io_error;
+ }
if (sfree (current_unit->s) == FAILURE)
goto io_error;
@@ -1432,9 +1475,9 @@ finalize_transfer (void)
if ((ionml != NULL) && (ioparm.namelist_name != NULL))
{
if (ioparm.namelist_read_mode)
- namelist_read();
+ namelist_read();
else
- namelist_write();
+ namelist_write();
}
transfer = NULL;
@@ -1537,6 +1580,7 @@ export_proto(st_read);
void
st_read (void)
{
+
library_start ();
data_transfer_init (1);
@@ -1553,11 +1597,11 @@ st_read (void)
break;
case AT_ENDFILE:
- if (!is_internal_unit())
- {
- generate_error (ERROR_END, NULL);
- current_unit->endfile = AFTER_ENDFILE;
- }
+ if (!is_internal_unit())
+ {
+ generate_error (ERROR_END, NULL);
+ current_unit->endfile = AFTER_ENDFILE;
+ }
break;
case AFTER_ENDFILE:
@@ -1582,6 +1626,7 @@ export_proto(st_write);
void
st_write (void)
{
+
library_start ();
data_transfer_init (0);
}
@@ -1608,11 +1653,11 @@ st_write_done (void)
case NO_ENDFILE:
if (current_unit->current_record > current_unit->last_record)
- {
- /* Get rid of whatever is after this record. */
- if (struncate (current_unit->s) == FAILURE)
- generate_error (ERROR_OS, NULL);
- }
+ {
+ /* Get rid of whatever is after this record. */
+ if (struncate (current_unit->s) == FAILURE)
+ generate_error (ERROR_OS, NULL);
+ }
current_unit->endfile = AT_ENDFILE;
break;
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index a24d29321d60..c7abf2bbd7d8 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1110,15 +1110,16 @@ write_es (fnode *f, const char *p, int len)
/* Take care of the X/TR descriptor. */
void
-write_x (fnode * f)
+write_x (int len, int nspaces)
{
char *p;
- p = write_block (f->u.n);
+ p = write_block (len);
if (p == NULL)
return;
- memset (p, ' ', f->u.n);
+ if (nspaces > 0)
+ memset (&p[len - nspaces], ' ', nspaces);
}
--
GitLab