Hello all,
The attached patch is part 1 of my effort to fix these X and T edit
descriptor issues. This one cleans up some really ugly output.
Before the patch with the test case provided by the reporter:
PI.................^@^@^@^@^@^@^@^@^@^@^@^@^@^@^@^@^@ 3.1415926535897931
REAL(PI)...........^@^@^@^@^@^@^@^@^@^@^@ 3.14159274
DBLE(PI)...........^@^@^@^@^@^@^@^@^@^@^@ 3.1415926535897931
RADIX..............^@^@^@^@^@^@^@^@^@^@^@ 3. 2
RANGE..............^@^@^@^@^@^@^@^@^@^@^@ 3. 307
PRECISION..........^@^@^@^@^@^@^@^@^@^@ 15
Which is complete garbage.
After the patch:
PI ................ 3.1415926535897931
REAL(PI) .......... 3.14159274
DBLE(PI) .......... 3.1415926535897931
RADIX ............. 2
RANGE ............. 307
PRECISION ......... 15
I greatly reduced the test case included in the patch. While working on
this one I discovered other problems not addressed by this patch and I
will address these through PR113897.
You will see some changes in the factoring of some of the code in the
case FMT_X:, case FMT_TR:, case FMT_TL:, case FMT_T:. I anticipate in
part 2 that I will be doing more specific changes on these.
Regression tested on x86_64_linux_gnu.
OK for trunk?
Regards,
Jerry
Author: Jerry DeLisle <jvdeli...@gcc.gnu.org>
Date: Mon Jan 27 19:08:46 2025 -0800
Fortran: Fix handling of the X edit descriptor.
This patch is a partial fix of handling of X edit descriptors
when combined with certain T edit descriptors.
PR libfortran/114618
libgfortran/ChangeLog:
* io/transfer.c (formatted_transfer_scalar_write): Change name
of vriable 'pos' to 'tab_pos' to improve clarity. Add new
variable next_pos when calculating the maximum position.
Update the calculation of pending spaces.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr114618.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/pr114618.f90 b/gcc/testsuite/gfortran.dg/pr114618.f90
new file mode 100644
index 00000000000..c06c4debe31
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114618.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! PR114618 Format produces incorrect output when contains 1x, ok when uses " "
+! aside: Before patch output1 is garbage.
+! Output should be 'RADIX ............. 2'
+program pr114618
+ implicit none
+ integer, parameter :: wp = kind(0d0)
+ real(kind=wp) :: pi = 3.14159265358979323846264338_wp
+ character(len=*), parameter:: fmt1 = '(19("."),t1,g0,1x,t21,g0)'
+ character(len=*), parameter:: fmt2 = '(19("."),t1,g0," ",t21,g0)'
+ character(30) :: output1, output2
+ write (output1, fmt1) 'RADIX', radix(pi)
+ write (output2, fmt2) 'RADIX', radix(pi)
+ if (output1 /= output2) stop 1
+end program pr114618
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index b3b72f39c5b..8a24a099afe 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2068,12 +2068,14 @@ static void
formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
- gfc_offset pos, bytes_used;
+ gfc_offset tab_pos, bytes_used;
const fnode *f;
format_token t;
int n;
int consume_data_flag;
+ tab_pos = 0; bytes_used = 0;
+
/* Change a complex data item into a pair of reals. */
n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
@@ -2398,10 +2400,17 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
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;
+ tab_pos = bytes_used + dtp->u.p.skips - 1;
+ dtp->u.p.pending_spaces = tab_pos - dtp->u.p.max_pos + 1;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+ ? f->u.n : dtp->u.p.pending_spaces;
+
+ if (t == FMT_X && tab_pos < dtp->u.p.max_pos)
+ {
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ }
/* 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
@@ -2414,35 +2423,50 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
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)
{
-
- /* 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;
+ 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;
}
- else /* FMT_T */
- pos = f->u.n - dtp->u.p.pending_spaces - 1;
+
+ tab_pos = bytes_used - f->u.n;
/* 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;
+ tab_pos = tab_pos < 0 ? 0 : tab_pos;
- dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+ dtp->u.p.skips = dtp->u.p.skips + tab_pos - bytes_used;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
- + pos - dtp->u.p.max_pos;
+ + tab_pos - dtp->u.p.max_pos;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+ ? 0 : dtp->u.p.pending_spaces;
+ break;
+
+ case FMT_T:
+ consume_data_flag = 0;
+ if (f->u.n < tab_pos + 1)
+ {
+ tab_pos = f->u.n;
+ dtp->u.p.skips = tab_pos - bytes_used - 1;
+ dtp->u.p.pending_spaces = tab_pos - bytes_used - 1;
+ }
+ else
+ {
+ tab_pos = f->u.n - dtp->u.p.pending_spaces - 1;
+
+ /* Excessive left tabbing is reset to the left tab limit. */
+ tab_pos = tab_pos < 0 ? 0 : tab_pos;
+
+ dtp->u.p.skips = dtp->u.p.skips + tab_pos - bytes_used;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ + tab_pos - dtp->u.p.max_pos;
+ }
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
? 0 : dtp->u.p.pending_spaces;
break;
@@ -2550,12 +2574,16 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
p = ((char *) p) + size;
}
+ /* Calculate the new max_pos if any. */
+ gfc_offset new_pos;
if (is_stream_io(dtp))
- pos = dtp->u.p.current_unit->fbuf->act;
+ new_pos = dtp->u.p.current_unit->fbuf->act;
else
- pos = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
+ new_pos = 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;
+ dtp->u.p.max_pos = (dtp->u.p.max_pos > new_pos) ?
+ dtp->u.p.max_pos : new_pos;
}
return;
