--- /dev/null
+c { dg-do run }
+c This program tests the fixes to PR22570.
+c
+c Provided by Paul Thomas - pault@gcc.gnu.org
+c
+ program x_slash
+ character*60 a
+ character*1 b, c
+
+ open (10, status = "scratch")
+
+c Check that lines with only x-editing followed by a slash generate
+c spaces and that subsequent lines have spaces where they should.
+c Line 1 we ignore.
+c Line 2 has nothing but x editing, followed by a slash.
+c Line 3 has x editing finished off by a 1h*
+
+ write (10, 100)
+ 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/)
+ rewind (10)
+
+ read (10, 200) a
+ read (10, 200) a
+ do i = 1,60
+ if (ichar(a(i:i)).ne.32) call abort ()
+ end do
+ read (10, 200) a
+ 200 format (a60)
+ do i = 1,59
+ if (ichar(a(i:i)).ne.32) call abort ()
+ end do
+ if (a(60:60).ne."*") call abort ()
+ rewind (10)
+
+c Check that sequences of t- and x-editing generate the correct
+c number of spaces.
+c Line 1 we ignore.
+c Line 2 has tabs to the right of present position.
+c Line 3 has tabs to the left of present position.
+
+ write (10, 101)
+ 101 format (1h1,58x,1h#,/,t38,2x,1h ,tr10,9x,1h$,/,
+ > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*)
+ rewind (10)
+
+ read (10, 200) a
+ read (10, 200) a
+ do i = 1,59
+ if (ichar(a(i:i)).ne.32) call abort ()
+ end do
+ if (a(60:60).ne."$") call abort ()
+ read (10, 200) a
+ if (a(1:10).ne."abcdghijkl") call abort ()
+ do i = 11,59
+ if (ichar(a(i:i)).ne.32) call abort ()
+ end do
+ if (a(60:60).ne."*") call abort ()
+ rewind (10)
+
+c Now repeat the first test, with the write broken up into three
+c separate statements. This checks that the position counters are
+c correctly reset for each statement.
+
+ write (10,102) "#"
+ write (10,103)
+ write (10,102) "$"
+ 102 format(59x,a1)
+ 103 format(60x)
+ rewind (10)
+ read (10, 200) a
+ read (10, 200) a
+ read (10, 200) a
+ do i = 11,59
+ if (ichar(a(i:i)).ne.32) call abort ()
+ end do
+ if (a(60:60).ne."$") call abort ()
+ rewind (10)
+
+c Next we check multiple read x- and t-editing.
+c First, tab to the right.
+
+ read (10, 201) b, c
+201 format (tr10,49x,a1,/,/,2x,t60,a1)
+ if ((b.ne."#").or.(c.ne."$")) call abort ()
+ rewind (10)
+
+c Now break it up into three reads and use left tabs.
+
+ read (10, 202) b
+202 format (10x,tl10,59x,a1)
+ read (10, 203)
+203 format ()
+ read (10, 204) c
+204 format (10x,t5,55x,a1)
+ if ((b.ne."#").or.(c.ne."$")) call abort ()
+ close (10)
+
+c Now, check that trailing spaces are not transmitted when we have
+c run out of data (Thanks to Jack Howarth for finding this one:
+c http://gcc.gnu.org/ml/fortran/2005-07/msg00395.html).
+
+ open (10, pad = "no", status = "scratch")
+ b = achar (0)
+ write (10, 105) 42
+ 105 format (i10,1x,i10)
+ write (10, 106)
+ 106 format ("============================")
+ rewind (10)
+ read (10, 205, iostat = ier) i, b
+ 205 format (i10,a1)
+ if ((ier.eq.0).or.(ichar(b).ne.0)) call abort ()
+
+c That's all for now, folks!
+
+ end
+
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. */
+ until a data producing format to suppress 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
+ if (g.mode == WRITING && skips != 0
+ && ((n>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 = (int)(current_unit->recl - current_unit->bytes_left);
+ if (skips > 0)
+ {
+ write_x (skips, pending_spaces);
+ max_pos = (int)(current_unit->recl - current_unit->bytes_left);
+ }
+ if (skips < 0)
+ {
+ move_pos_offset (current_unit->s, skips);
+ current_unit->bytes_left -= (gfc_offset)skips;
+ }
skips = pending_spaces = 0;
}
/* Writes occur just before the switch on f->format, above, so that
trailing blanks are suppressed. */
- if (skips > 0)
+ if (g.mode == READING)
{
- if (g.mode == READING)
+ if (skips > 0)
{
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;
+ if (skips < 0)
+ {
+ move_pos_offset (current_unit->s, skips);
+ current_unit->bytes_left -= (gfc_offset)skips;
+ skips = pending_spaces = 0;
+ }
}
break;
case FMT_SLASH:
consume_data_flag = 0 ;
skips = pending_spaces = 0;
- current_unit->bytes_left = 0;
next_record (0);
break;
if (g.mode == READING)
skips = 0;
- pos = current_unit->recl - current_unit->bytes_left;
+ pos = (int)(current_unit->recl - current_unit->bytes_left);
max_pos = (max_pos > pos) ? max_pos : pos;
}
projects / gcc.git / commitdiff