gcc/testsuite/gfortran.dg/x_slash_1.f

   1 c { dg-do run { target fd_truncate } }
   2 c { dg-options "-std=legacy" }
   3 c
   4 c This program tests the fixes to PR22570.
   5 c
   6 c Provided by Paul Thomas - pault@gcc.gnu.org
   7 c
   8        program x_slash
   9        character*60 a
  10        character*1  b, c
  11
  12        open (10, status = "scratch")
  13
  14 c Check that lines with only x-editing followed by a slash generate
  15 c spaces and that subsequent lines have spaces where they should.
  16 c Line 1 we ignore.
  17 c Line 2 has nothing but x editing, followed by a slash.
  18 c Line 3 has x editing finished off by a 1h*
  19
  20        write (10, 100)
  21  100   format (1h1,58x,1h!,/,60x,/,59x,1h*,/)
  22        rewind (10)
  23
  24        read (10, 200) a
  25        read (10, 200) a
  26        do i = 1,60
  27          if (ichar(a(i:i)).ne.32) call abort ()
  28        end do
  29        read (10, 200) a
  30  200   format (a60)
  31        do i = 1,59
  32          if (ichar(a(i:i)).ne.32) call abort ()
  33        end do
  34        if (a(60:60).ne."*") call abort ()
  35        rewind (10)
  36
  37 c Check that sequences of t- and x-editing generate the correct
  38 c number of spaces.
  39 c Line 1 we ignore.
  40 c Line 2 has tabs to the right of present position.
  41 c Line 3 has tabs to the left of present position.
  42
  43        write (10, 101)
  44  101   format (1h1,58x,1h#,/,t38,2x,1h ,tr10,9x,1h$,/,
  45      >         6habcdef,tl4,2x,6hghijkl,t1,59x,1h*)
  46        rewind (10)
  47
  48        read (10, 200) a
  49        read (10, 200) a
  50        do i = 1,59
  51          if (ichar(a(i:i)).ne.32) call abort ()
  52        end do
  53        if (a(60:60).ne."$") call abort ()
  54        read (10, 200) a
  55        if (a(1:10).ne."abcdghijkl") call abort ()
  56        do i = 11,59
  57          if (ichar(a(i:i)).ne.32) call abort ()
  58        end do
  59        if (a(60:60).ne."*") call abort ()
  60        rewind (10)
  61
  62 c Now repeat the first test, with the write broken up into three
  63 c separate statements. This checks that the position counters are
  64 c correctly reset for each statement.
  65
  66        write (10,102) "#"
  67        write (10,103)
  68        write (10,102) "$"
  69  102   format(59x,a1)
  70  103   format(60x)
  71        rewind (10)
  72        read (10, 200) a
  73        read (10, 200) a
  74        read (10, 200) a
  75        do i = 11,59
  76          if (ichar(a(i:i)).ne.32) call abort ()
  77        end do
  78        if (a(60:60).ne."$") call abort ()
  79        rewind (10)
  80
  81 c Next we check multiple read x- and t-editing.
  82 c First, tab to the right.
  83
  84        read (10, 201) b, c
  85 201    format (tr10,49x,a1,/,/,2x,t60,a1)
  86        if ((b.ne."#").or.(c.ne."$")) call abort ()
  87        rewind (10)
  88
  89 c Now break it up into three reads and use left tabs.
  90
  91        read (10, 202) b
  92 202    format (10x,tl10,59x,a1)
  93        read (10, 203)
  94 203    format ()
  95        read (10, 204) c
  96 204    format (10x,t5,55x,a1)
  97        if ((b.ne."#").or.(c.ne."$")) call abort ()
  98        close (10)
  99
 100 c Now, check that trailing spaces are not transmitted when we have
 101 c run out of data (Thanks to Jack Howarth for finding this one:
 102 c http://gcc.gnu.org/ml/fortran/2005-07/msg00395.html).
 103
 104        open (10, pad = "no", status = "scratch")
 105        b = achar (0)
 106        write (10, 105) 42
 107   105  format (i10,1x,i10)
 108        write (10, 106)
 109   106  format ("============================")
 110        rewind (10)
 111        read (10, 205, iostat = ier) i, b
 112   205  format (i10,a1)
 113        if ((ier.eq.0).or.(ichar(b).ne.0)) call abort ()
 114
 115 c That's all for now, folks!
 116
 117        end
 118