diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1c94063bc1b..b3585c7d75b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2005-07-12 Paul Thomas + + 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 * 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 400b85b6bf1..9d196331dd1 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 00000000000..3a313cd2b59 --- /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 + 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 25f55c7398a..48788f197cb 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2005-07-12 Paul Thomas + + 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 * io/read.c (read_complex): Prevent X formatting during reads diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index a301682a62c..37bdb3ebdfa 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 bcba218c50a..161e5cca402 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). */ - 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: 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; - } + 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); + /* 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; - if (m == 0) - break; + skips = skips + pos - (current_unit->recl - current_unit->bytes_left); + pending_spaces = pending_spaces + pos - max_pos; - 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; - } + 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); + { + 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; - } + /* 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 (p == NULL) + { + generate_error (ERROR_OS, NULL); + break; + } - if (length == 0) - { - current_unit->endfile = AT_ENDFILE; - 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 a24d29321d6..c7abf2bbd7d 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); }