On 1/29/25 10:30 AM, Jerry D wrote:
Follow-up:
On 1/28/25 1:33 PM, Harald Anlauf wrote:
Jerry,
while I haven't read your actual patch yet, I think the testcase
is slightly incorrect. In fact, Intel, NAG, Nvidia and AMD flang
disagree with it.
--- snip ---
The following adjustment to the patch puts this right.
case FMT_X:
case FMT_TR:
consume_data_flag = 0;
dtp->u.p.skips += f->u.n;
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;
//}
Interestingly, it also fixes a floating point exception I ran into while
setting up another test case for part 2 of this effort. I suspect this
may be what was detected by the auto patch tester.
I will clean this up, adjust the test case for this part and re-submit.
Regards,
Jerry
Here is version 2 of the patch cleaned up and with the test case revised
accordingly.
Thank you Herald for helping with my blindness.
Regressions tested on x86_64. I will wait a bit to see if the auto patch
tester reports anything.
Otherwise, OK for trunk?
Regards,
Jerry
PS working on part 2 still.
diff --git a/gcc/testsuite/gfortran.dg/pr114618.f90 b/gcc/testsuite/gfortran.dg/pr114618.f90
new file mode 100644
index 00000000000..835597b8513
--- /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.
+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(21) :: output1, output2
+ write (output1, fmt1) 'RADIX', radix(pi)
+ write (output2, fmt2) 'RADIX', radix(pi)
+ if (output1 /= 'RADIX.............. 2') stop 1
+ if (output2 /= 'RADIX ............. 2') stop 2
+end program pr114618
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index b3b72f39c5b..3fc53938b4a 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,12 @@ 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;
+
/* 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 +2418,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 +2569,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;
