git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r102008
This commit is contained in:
Paul Thomas 2005-07-14 06:21:59 +00:00
parent 93e261acea
commit be0cc7e21c
7 changed files with 189 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/testsuite/ChangeLog
View File

@ -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> 2005-07-14 Steven G. Kargl <kargls@comcast.net>
* gfortran.dg/char_array_constructor.f90: New test. * gfortran.dg/char_array_constructor.f90: New test.

2
gcc/testsuite/gfortran.dg/g77/f77-edit-x-out.f
View File

@ -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)" } 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 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)" } 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 end

13
gcc/testsuite/gfortran.dg/tl_editing.f90 Normal file
View File

@ -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

12
libgfortran/ChangeLog
View File

@ -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> 2005-07-13 Paul Thomas <pault@gcc.gnu.org>
* io/read.c (read_complex): Prevent X formatting during reads * io/read.c (read_complex): Prevent X formatting during reads

2
libgfortran/io/io.h
View File

@ -638,7 +638,7 @@ internal_proto(write_l);
extern void write_o (fnode *, const char *, int); extern void write_o (fnode *, const char *, int);
internal_proto(write_o); internal_proto(write_o);
extern void write_x (fnode *); extern void write_x (int, int);
internal_proto(write_x); internal_proto(write_x);
extern void write_z (fnode *, const char *, int); extern void write_z (fnode *, const char *, int);

259
libgfortran/io/transfer.c
View File

@ -82,6 +82,13 @@ gfc_unit *current_unit = NULL;
static int sf_seen_eor = 0; static int sf_seen_eor = 0;
static int eor_condition = 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]; char scratch[SCRATCH_SIZE];
static char *line_buffer = NULL; static char *line_buffer = NULL;
@ -166,11 +173,11 @@ read_sf (int *length)
do do
{ {
if (is_internal_unit()) if (is_internal_unit())
{ {
/* readlen may be modified inside salloc_r if /* readlen may be modified inside salloc_r if
is_internal_unit() is true. */ is_internal_unit() is true. */
readlen = 1; readlen = 1;
} }
q = salloc_r (current_unit->s, &readlen); q = salloc_r (current_unit->s, &readlen);
if (q == NULL) if (q == NULL)
@ -204,7 +211,7 @@ read_sf (int *length)
current_unit->bytes_left = 0; current_unit->bytes_left = 0;
*length = n; *length = n;
sf_seen_eor = 1; sf_seen_eor = 1;
break; break;
} }
@ -437,8 +444,9 @@ require_type (bt expected, bt actual, fnode * f)
static void static void
formatted_transfer (bt type, void *p, int len) formatted_transfer (bt type, void *p, int len)
{ {
int pos ,m ; int pos;
fnode *f; fnode *f;
format_token t;
int n; int n;
int consume_data_flag; int consume_data_flag;
@ -456,12 +464,12 @@ formatted_transfer (bt type, void *p, int len)
for (;;) for (;;)
{ {
/* If reversion has occurred and there is another real data item, /* 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) if (g.reversion_flag && n > 0)
{ {
g.reversion_flag = 0; g.reversion_flag = 0;
next_record (0); next_record (0);
} }
consume_data_flag = 1 ; consume_data_flag = 1 ;
if (ioparm.library_return != LIBRARY_OK) if (ioparm.library_return != LIBRARY_OK)
@ -469,9 +477,23 @@ formatted_transfer (bt type, void *p, int len)
f = next_format (); f = next_format ();
if (f == NULL) if (f == NULL)
return; /* No data descriptors left (already raised). */ return; /* No data descriptors left (already raised). */
switch (f->format) /* 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 (t)
{ {
case FMT_I: case FMT_I:
if (n == 0) if (n == 0)
@ -651,7 +673,7 @@ formatted_transfer (bt type, void *p, int len)
break; break;
case FMT_STRING: case FMT_STRING:
consume_data_flag = 0 ; consume_data_flag = 0 ;
if (g.mode == READING) if (g.mode == READING)
{ {
format_error (f, "Constant string in input format"); format_error (f, "Constant string in input format");
@ -660,90 +682,100 @@ formatted_transfer (bt type, void *p, int len)
write_constant_string (f); write_constant_string (f);
break; break;
/* Format codes that don't transfer data. */ /* Format codes that don't transfer data. */
case FMT_X: case FMT_X:
case FMT_TR: 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) if (g.mode == READING)
read_x (f); read_x (f);
else
write_x (f);
break; break;
case FMT_TL: case FMT_TL:
case FMT_T: case FMT_T:
if (f->format == FMT_TL) if (f->format == FMT_TL)
pos = current_unit->recl - current_unit->bytes_left - f->u.n; pos = current_unit->recl - current_unit->bytes_left - f->u.n;
else /* FMT_T */ else /* FMT_T */
{ {
consume_data_flag = 0; consume_data_flag = 0;
pos = f->u.n - 1; pos = f->u.n - 1;
} }
if (pos < 0 || pos >= current_unit->recl ) /* Standard 10.6.1.1: excessive left tabbing is reset to the
{ left tab limit. We do not check if the position has gone
generate_error (ERROR_EOR, "T or TL edit position error"); beyond the end of record because a subsequent tab could
break ; bring us back again. */
} pos = pos < 0 ? 0 : pos;
m = pos - (current_unit->recl - current_unit->bytes_left);
if (m == 0) skips = skips + pos - (current_unit->recl - current_unit->bytes_left);
break; pending_spaces = pending_spaces + pos - max_pos;
if (m > 0) if (skips == 0)
{ break;
f->u.n = m;
if (g.mode == READING) /* Writes occur just before the switch on f->format, above, so that
read_x (f); trailing blanks are suppressed. */
else if (skips > 0)
write_x (f); {
} if (g.mode == READING)
if (m < 0) {
{ f->u.n = skips;
move_pos_offset (current_unit->s,m); read_x (f);
current_unit->bytes_left -= m; }
} }
if (skips < 0)
{
move_pos_offset (current_unit->s, skips);
current_unit->bytes_left -= skips;
skips = pending_spaces = 0;
}
break; break;
case FMT_S: case FMT_S:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.sign_status = SIGN_S; g.sign_status = SIGN_S;
break; break;
case FMT_SS: case FMT_SS:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.sign_status = SIGN_SS; g.sign_status = SIGN_SS;
break; break;
case FMT_SP: case FMT_SP:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.sign_status = SIGN_SP; g.sign_status = SIGN_SP;
break; break;
case FMT_BN: case FMT_BN:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.blank_status = BLANK_NULL; g.blank_status = BLANK_NULL;
break; break;
case FMT_BZ: case FMT_BZ:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.blank_status = BLANK_ZERO; g.blank_status = BLANK_ZERO;
break; break;
case FMT_P: case FMT_P:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.scale_factor = f->u.k; g.scale_factor = f->u.k;
break; break;
case FMT_DOLLAR: case FMT_DOLLAR:
consume_data_flag = 0 ; consume_data_flag = 0 ;
g.seen_dollar = 1; g.seen_dollar = 1;
break; break;
case FMT_SLASH: case FMT_SLASH:
consume_data_flag = 0 ; consume_data_flag = 0 ;
next_record (0); next_record (0);
break; break;
@ -752,7 +784,7 @@ formatted_transfer (bt type, void *p, int len)
particular preventing another / descriptor from being particular preventing another / descriptor from being
processed) unless there is another data item to be processed) unless there is another data item to be
transferred. */ transferred. */
consume_data_flag = 0 ; consume_data_flag = 0 ;
if (n == 0) if (n == 0)
return; return;
break; break;
@ -776,8 +808,15 @@ formatted_transfer (bt type, void *p, int len)
if ((consume_data_flag > 0) && (n > 0)) if ((consume_data_flag > 0) && (n > 0))
{ {
n--; 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; return;
@ -977,7 +1016,7 @@ data_transfer_init (int read_flag)
{ {
current_unit->recl = file_length(current_unit->s); current_unit->recl = file_length(current_unit->s);
if (g.mode==WRITING) if (g.mode==WRITING)
empty_internal_buffer (current_unit->s); empty_internal_buffer (current_unit->s);
} }
/* Check the action. */ /* Check the action. */
@ -1007,14 +1046,14 @@ data_transfer_init (int read_flag)
if (ioparm.namelist_name != NULL && ionml != NULL) if (ioparm.namelist_name != NULL && ionml != NULL)
{ {
if(ioparm.format != NULL) if(ioparm.format != NULL)
generate_error (ERROR_OPTION_CONFLICT, generate_error (ERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist"); "A format cannot be specified with a namelist");
} }
else if (current_unit->flags.form == FORM_FORMATTED && 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, 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) 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 */ /* Check to see if we might be reading what we wrote before */
if (g.mode == READING && current_unit->mode == WRITING) if (g.mode == READING && current_unit->mode == WRITING)
flush(current_unit->s); flush(current_unit->s);
/* Position the file. */ /* Position the file. */
if (sseek (current_unit->s, if (sseek (current_unit->s,
(ioparm.rec - 1) * current_unit->recl) == FAILURE) (ioparm.rec - 1) * current_unit->recl) == FAILURE)
generate_error (ERROR_OS, NULL); generate_error (ERROR_OS, NULL);
} }
@ -1121,7 +1160,7 @@ data_transfer_init (int read_flag)
if (g.mode == WRITING if (g.mode == WRITING
&& current_unit->flags.access == ACCESS_SEQUENTIAL && current_unit->flags.access == ACCESS_SEQUENTIAL
&& current_unit->current_record == 0) && current_unit->current_record == 0)
struncate(current_unit->s); struncate(current_unit->s);
current_unit->mode = g.mode; current_unit->mode = g.mode;
@ -1147,10 +1186,10 @@ data_transfer_init (int read_flag)
else else
{ {
if (ioparm.list_format) if (ioparm.list_format)
{ {
transfer = list_formatted_read; transfer = list_formatted_read;
init_at_eol(); init_at_eol();
} }
else else
transfer = formatted_transfer; transfer = formatted_transfer;
} }
@ -1185,6 +1224,10 @@ data_transfer_init (int read_flag)
current_unit->read_bad = 1; 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. */ /* Start the data transfer if we are doing a formatted transfer. */
if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
&& ioparm.namelist_name == NULL && ionml == NULL) && ioparm.namelist_name == NULL && ionml == NULL)
@ -1256,27 +1299,27 @@ next_record_r (void)
} }
do do
{ {
p = salloc_r (current_unit->s, &length); p = salloc_r (current_unit->s, &length);
/* In case of internal file, there may not be any '\n'. */ /* In case of internal file, there may not be any '\n'. */
if (is_internal_unit() && p == NULL) if (is_internal_unit() && p == NULL)
{ {
break; break;
} }
if (p == NULL) if (p == NULL)
{ {
generate_error (ERROR_OS, NULL); generate_error (ERROR_OS, NULL);
break; break;
} }
if (length == 0) if (length == 0)
{ {
current_unit->endfile = AT_ENDFILE; current_unit->endfile = AT_ENDFILE;
break; break;
} }
} }
while (*p != '\n'); while (*p != '\n');
break; break;
@ -1315,7 +1358,7 @@ next_record_w (void)
case UNFORMATTED_DIRECT: case UNFORMATTED_DIRECT:
if (sfree (current_unit->s) == FAILURE) if (sfree (current_unit->s) == FAILURE)
goto io_error; goto io_error;
break; break;
case UNFORMATTED_SEQUENTIAL: case UNFORMATTED_SEQUENTIAL:
@ -1357,12 +1400,12 @@ next_record_w (void)
p = salloc_w (current_unit->s, &length); p = salloc_w (current_unit->s, &length);
if (!is_internal_unit()) if (!is_internal_unit())
{ {
if (p) if (p)
*p = '\n'; /* No CR for internal writes. */ *p = '\n'; /* No CR for internal writes. */
else else
goto io_error; goto io_error;
} }
if (sfree (current_unit->s) == FAILURE) if (sfree (current_unit->s) == FAILURE)
goto io_error; goto io_error;
@ -1432,9 +1475,9 @@ finalize_transfer (void)
if ((ionml != NULL) && (ioparm.namelist_name != NULL)) if ((ionml != NULL) && (ioparm.namelist_name != NULL))
{ {
if (ioparm.namelist_read_mode) if (ioparm.namelist_read_mode)
namelist_read(); namelist_read();
else else
namelist_write(); namelist_write();
} }
transfer = NULL; transfer = NULL;
@ -1537,6 +1580,7 @@ export_proto(st_read);
void void
st_read (void) st_read (void)
{ {
library_start (); library_start ();
data_transfer_init (1); data_transfer_init (1);
@ -1553,11 +1597,11 @@ st_read (void)
break; break;
case AT_ENDFILE: case AT_ENDFILE:
if (!is_internal_unit()) if (!is_internal_unit())
{ {
generate_error (ERROR_END, NULL); generate_error (ERROR_END, NULL);
current_unit->endfile = AFTER_ENDFILE; current_unit->endfile = AFTER_ENDFILE;
} }
break; break;
case AFTER_ENDFILE: case AFTER_ENDFILE:
@ -1582,6 +1626,7 @@ export_proto(st_write);
void void
st_write (void) st_write (void)
{ {
library_start (); library_start ();
data_transfer_init (0); data_transfer_init (0);
} }
@ -1608,11 +1653,11 @@ st_write_done (void)
case NO_ENDFILE: case NO_ENDFILE:
if (current_unit->current_record > current_unit->last_record) if (current_unit->current_record > current_unit->last_record)
{ {
/* Get rid of whatever is after this record. */ /* Get rid of whatever is after this record. */
if (struncate (current_unit->s) == FAILURE) if (struncate (current_unit->s) == FAILURE)
generate_error (ERROR_OS, NULL); generate_error (ERROR_OS, NULL);
} }
current_unit->endfile = AT_ENDFILE; current_unit->endfile = AT_ENDFILE;
break; break;

7
libgfortran/io/write.c
View File

@ -1110,15 +1110,16 @@ write_es (fnode *f, const char *p, int len)
/* Take care of the X/TR descriptor. */ /* Take care of the X/TR descriptor. */
void void
write_x (fnode * f) write_x (int len, int nspaces)
{ {
char *p; char *p;
p = write_block (f->u.n); p = write_block (len);
if (p == NULL) if (p == NULL)
return; return;
memset (p, ' ', f->u.n); if (nspaces > 0)
memset (&p[len - nspaces], ' ', nspaces);
} }