gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90

   1 ! Test alternate entry points for functions when the result types
   2 ! of all entry points match
   3
   4         function f1 (str, i, j) result (r)
   5         character str*(*), r1*(*), r2*(*), r*(*)
   6         integer i, j
   7         r = str (i:j)
   8         return
   9         entry e1 (str, i, j) result (r1)
  10         i = i + 1
  11         entry e2 (str, i, j) result (r2)
  12         j = j - 1
  13         r2 = str (i:j)
  14         end function
  15
  16         function f3 () result (r)
  17         character r3*5, r4*5, r*5
  18         integer i
  19         r = 'ABCDE'
  20         return
  21         entry e3 (i) result (r3)
  22         entry e4 (i) result (r4)
  23         if (i .gt. 0) then
  24           r3 = 'abcde'
  25         else
  26           r4 = 'UVWXY'
  27         endif
  28         end function
  29
  30         program entrytest
  31         character f1*16, e1*16, e2*16, str*16, ret*16
  32         character f3*5, e3*5, e4*5
  33         integer i, j
  34         str = 'ABCDEFGHIJ'
  35         i = 2
  36         j = 6
  37         ret = f1 (str, i, j)
  38         if ((i .ne. 2) .or. (j .ne. 6)) call abort ()
  39         if (ret .ne. 'BCDEF') call abort ()
  40         ret = e1 (str, i, j)
  41         if ((i .ne. 3) .or. (j .ne. 5)) call abort ()
  42         if (ret .ne. 'CDE') call abort ()
  43         ret = e2 (str, i, j)
  44         if ((i .ne. 3) .or. (j .ne. 4)) call abort ()
  45         if (ret .ne. 'CD') call abort ()
  46         if (f3 () .ne. 'ABCDE') call abort ()
  47         if (e3 (1) .ne. 'abcde') call abort ()
  48         if (e4 (1) .ne. 'abcde') call abort ()
  49         if (e3 (0) .ne. 'UVWXY') call abort ()
  50         if (e4 (0) .ne. 'UVWXY') call abort ()
  51         end program