flang/test/Semantics/label01.F90

   1 ! RUN: %flang_fc1 -fdebug-unparse-with-symbols -DSTRICT_F18 -pedantic %s 2>&1 | FileCheck %s
   2 ! RUN: %flang_fc1 -fdebug-unparse-with-symbols -DARCHAIC_FORTRAN %s 2>&1 | FileCheck %s
   3 ! CHECK-NOT: :{{[[:space:]]}}error:{{[[:space:]]}}
   4 ! FIXME: the above check line does not work because diags are not emitted with error: in them.
   5
   6 ! these are the conformance tests
   7 ! define STRICT_F18 to eliminate tests of features not in F18
   8 ! define ARCHAIC_FORTRAN to add test of feature found in Fortran before F95
   9
  10 subroutine sub00(a,b,n,m)
  11   integer :: n, m
  12   real a(n)
  13   real :: b(m)
  14 1 print *, n, m
  15 1234 print *, a(n), b(1)
  16 99999 print *, a(1), b(m)
  17 end subroutine sub00
  18
  19 subroutine do_loop01(a,n)
  20   integer :: n
  21   real, dimension(n) :: a
  22   do 10 i = 1, n
  23      print *, i, a(i)
  24 10   continue
  25 end subroutine do_loop01
  26
  27 subroutine do_loop02(a,n)
  28   integer :: n
  29   real, dimension(n,n) :: a
  30   do 10 j = 1, n
  31      do 10 i = 1, n
  32         print *, i, j, a(i, j)
  33 10      continue
  34 end subroutine do_loop02
  35
  36 #ifndef STRICT_F18
  37 subroutine do_loop03(a,n)
  38   integer :: n
  39   real, dimension(n) :: a
  40   do 10 i = 1, n
  41 10   print *, i, a(i)           ! extension (not f18)
  42 end subroutine do_loop03
  43
  44 subroutine do_loop04(a,n)
  45   integer :: n
  46   real :: a(n,n)
  47   do 10 j = 1, n
  48      do 10 i = 1, n
  49 10      print *, i, j, a(i, j)  ! extension (not f18)
  50 end subroutine do_loop04
  51
  52 subroutine do_loop05(a,n)
  53   integer :: n
  54   real a(n,n,n)
  55   do 10 k = 1, n
  56      do 10 j = 1, n
  57         do 10 i = 1, n
  58 10         print *, a(i, j, k)  ! extension (not f18)
  59 end subroutine do_loop05
  60 #endif
  61
  62 subroutine do_loop06(a,n)
  63   integer :: n
  64   real, dimension(n) :: a
  65   loopname: do i = 1, n
  66      print *, i, a(i)
  67      if (i .gt. 50) then
  68 678     exit
  69      end if
  70   end do loopname
  71 end subroutine do_loop06
  72
  73 subroutine do_loop07(a,n)
  74   integer :: n
  75   real, dimension(n,n) :: a
  76   loopone: do j = 1, n
  77      looptwo: do i = 1, n
  78         print *, i, j, a(i, j)
  79      end do looptwo
  80   end do loopone
  81 end subroutine do_loop07
  82
  83 #ifndef STRICT_F18
  84 subroutine do_loop08(a,b,n,m,nn)
  85   integer :: n, m, nn
  86   real, dimension(n,n) :: a
  87   real b(m,nn)
  88   loopone: do j = 1, n
  89      condone: if (m .lt. n) then
  90         looptwo: do i = 1, m
  91            condtwo: if (n .lt. nn) then
  92               b(m-i,j) = s(m-i,j)
  93               if (i .eq. j) then
  94                  goto 111
  95               end if
  96            else
  97               cycle loopone
  98            end if condtwo
  99         end do looptwo
 100      else if (n .lt. m) then
 101         loopthree: do i = 1, n
 102            condthree: if (n .lt. nn) then
 103               a(i,j) = b(i,j)
 104               if (i .eq. j) then
 105                  return
 106               end if
 107            else
 108               exit loopthree
 109            end if condthree
 110         end do loopthree
 111      end if condone
 112   end do loopone
 113 111 print *, "done"
 114 end subroutine do_loop08
 115 #endif
 116
 117 #ifndef STRICT_F18
 118 ! extended ranges supported by PGI, gfortran gives warnings
 119 subroutine do_loop09(a,n,j)
 120   integer :: n
 121   real a(n)
 122   goto 400
 123 200 print *, "found the index", j
 124   print *, "value at", j, "is", a(j)
 125   goto 300 ! FIXME: emits diagnostic even without -pedantic
 126 400  do 100 i = 1, n
 127      if (i .eq. j) then
 128         goto 200        ! extension: extended GOTO ranges
 129 300     continue
 130      else
 131         print *, a(i)
 132      end if
 133 100 end do
 134 500 continue
 135 end subroutine do_loop09
 136 #endif
 137
 138 subroutine goto10(a,b,n)
 139   dimension :: a(3), b(3)
 140   goto 10
 141 10 print *,"x"
 142 4 labelit: if (a(n-1) .ne. b(n-2)) then
 143      goto 567
 144   end if labelit
 145 567 end subroutine goto10
 146
 147 subroutine computed_goto11(i,j,k)
 148   goto (100,110,120) i
 149 100 print *, j
 150   goto 200
 151 110 print *, k
 152   goto 200
 153 120 print *, -1
 154 200 end subroutine computed_goto11
 155
 156 #ifndef STRICT_F18
 157 subroutine arith_if12(i)
 158   if (i) 300,310,320
 159 300 continue
 160   print *,"<"
 161   goto 340
 162 310 print *,"=="
 163 340 goto 330
 164 320 print *,">"
 165 330 goto 350
 166 350 continue
 167 end subroutine arith_if12
 168 #endif
 169
 170 #ifndef STRICT_F18
 171 subroutine alt_return_spec13(i,*,*,*)
 172 9 continue
 173 8 labelme: if (i .lt. 42) then
 174 7  return 1
 175 6 else if (i .lt. 94) then
 176 5  return 2
 177 4 else if (i .lt. 645) then
 178 3  return 3
 179 2 end if labelme
 180 1 end subroutine alt_return_spec13
 181
 182 subroutine alt_return_spec14(i)
 183   call alt_return_spec13(i,*6000,*6130,*6457)
 184   print *, "Hi!"
 185 6000 continue
 186 6100 print *,"123"
 187 6130 continue
 188 6400 print *,"abc"
 189 6457 continue
 190 6650 print *,"!@#"
 191 end subroutine alt_return_spec14
 192 #endif
 193
 194 #ifndef STRICT_F18
 195 subroutine specifiers15(a,b,x)
 196   integer x
 197   OPEN (10, file="myfile.dat", err=100)
 198   READ (10,20,end=200,size=x,advance='no',eor=300) a
 199   goto 99
 200 99 CLOSE (10)
 201   goto 40
 202 100 print *,"error opening"
 203 101 return
 204 200 print *,"end of file"
 205 202 return
 206 300 print *, "end of record"
 207 303 return
 208 20 FORMAT (1x,F5.1)
 209 30 FORMAT (2x,F6.2)
 210 40 OPEN (11, file="myfile2.dat", err=100)
 211   goto 50
 212 50 WRITE (11,30,err=100) b
 213   CLOSE (11)
 214 end subroutine specifiers15
 215 #endif
 216
 217 #if !defined(STRICT_F18) && defined(ARCHAIC_FORTRAN)
 218 ! assigned goto was deleted in F95. PGI supports, gfortran gives warnings
 219 subroutine assigned_goto16
 220   assign 10 to i
 221   goto i (10, 20, 30)
 222 10 continue
 223   assign 20 to i
 224 20 continue
 225   assign 30 to i
 226 30 pause
 227   print *, "archaic feature!"
 228 end subroutine assigned_goto16
 229 #endif