xref: /llvm-project/flang/test/Semantics/label01.F90 (revision 31ad5c14fefa66085eff3629c0cc8393556ba849)

! RUN: %flang_fc1 -fdebug-unparse-with-symbols -DSTRICT_F18 -pedantic %s 2>&1 | FileCheck %s
! RUN: %flang_fc1 -fdebug-unparse-with-symbols -DARCHAIC_FORTRAN %s 2>&1 | FileCheck %s
! CHECK-NOT: :{{[[:space:]]}}error:{{[[:space:]]}}
! FIXME: the above check line does not work because diags are not emitted with error: in them.

! these are the conformance tests
! define STRICT_F18 to eliminate tests of features not in F18
! define ARCHAIC_FORTRAN to add test of feature found in Fortran before F95

subroutine sub00(a,b,n,m)
  integer :: n, m
  real a(n)
  real :: b(m)
1 print *, n, m
1234 print *, a(n), b(1)
99999 print *, a(1), b(m)
end subroutine sub00

subroutine do_loop01(a,n)
  integer :: n
  real, dimension(n) :: a
  do 10 i = 1, n
     print *, i, a(i)
10   continue
end subroutine do_loop01

subroutine do_loop02(a,n)
  integer :: n
  real, dimension(n,n) :: a
  do 10 j = 1, n
     do 10 i = 1, n
        print *, i, j, a(i, j)
10      continue
end subroutine do_loop02

#ifndef STRICT_F18
subroutine do_loop03(a,n)
  integer :: n
  real, dimension(n) :: a
  do 10 i = 1, n
10   print *, i, a(i)		! extension (not f18)
end subroutine do_loop03

subroutine do_loop04(a,n)
  integer :: n
  real :: a(n,n)
  do 10 j = 1, n
     do 10 i = 1, n
10      print *, i, j, a(i, j)	! extension (not f18)
end subroutine do_loop04

subroutine do_loop05(a,n)
  integer :: n
  real a(n,n,n)
  do 10 k = 1, n
     do 10 j = 1, n
        do 10 i = 1, n
10         print *, a(i, j, k)	! extension (not f18)
end subroutine do_loop05
#endif

subroutine do_loop06(a,n)
  integer :: n
  real, dimension(n) :: a
  loopname: do i = 1, n
     print *, i, a(i)
     if (i .gt. 50) then
678     exit
     end if
  end do loopname
end subroutine do_loop06

subroutine do_loop07(a,n)
  integer :: n
  real, dimension(n,n) :: a
  loopone: do j = 1, n
     looptwo: do i = 1, n
        print *, i, j, a(i, j)
     end do looptwo
  end do loopone
end subroutine do_loop07

#ifndef STRICT_F18
subroutine do_loop08(a,b,n,m,nn)
  integer :: n, m, nn
  real, dimension(n,n) :: a
  real b(m,nn)
  loopone: do j = 1, n
     condone: if (m .lt. n) then
        looptwo: do i = 1, m
           condtwo: if (n .lt. nn) then
              b(m-i,j) = s(m-i,j)
              if (i .eq. j) then
                 goto 111
              end if
           else
              cycle loopone
           end if condtwo
        end do looptwo
     else if (n .lt. m) then
        loopthree: do i = 1, n
           condthree: if (n .lt. nn) then
              a(i,j) = b(i,j)
              if (i .eq. j) then
                 return
              end if
           else
              exit loopthree
           end if condthree
        end do loopthree
     end if condone
  end do loopone
111 print *, "done"
end subroutine do_loop08
#endif

#ifndef STRICT_F18
! extended ranges supported by PGI, gfortran gives warnings
subroutine do_loop09(a,n,j)
  integer :: n
  real a(n)
  goto 400
200 print *, "found the index", j
  print *, "value at", j, "is", a(j)
  goto 300 ! FIXME: emits diagnostic even without -pedantic
400  do 100 i = 1, n
     if (i .eq. j) then
        goto 200	! extension: extended GOTO ranges
300     continue
     else
        print *, a(i)
     end if
100 end do
500 continue
end subroutine do_loop09
#endif

subroutine goto10(a,b,n)
  dimension :: a(3), b(3)
  goto 10
10 print *,"x"
4 labelit: if (a(n-1) .ne. b(n-2)) then
     goto 567
  end if labelit
567 end subroutine goto10

subroutine computed_goto11(i,j,k)
  goto (100,110,120) i
100 print *, j
  goto 200
110 print *, k
  goto 200
120 print *, -1
200 end subroutine computed_goto11

#ifndef STRICT_F18
subroutine arith_if12(i)
  if (i) 300,310,320
300 continue
  print *,"<"
  goto 340
310 print *,"=="
340 goto 330
320 print *,">"
330 goto 350
350 continue
end subroutine arith_if12
#endif

#ifndef STRICT_F18
subroutine alt_return_spec13(i,*,*,*)
9 continue
8 labelme: if (i .lt. 42) then
7  return 1
6 else if (i .lt. 94) then
5  return 2
4 else if (i .lt. 645) then
3  return 3
2 end if labelme
1 end subroutine alt_return_spec13

subroutine alt_return_spec14(i)
  call alt_return_spec13(i,*6000,*6130,*6457)
  print *, "Hi!"
6000 continue
6100 print *,"123"
6130 continue
6400 print *,"abc"
6457 continue
6650 print *,"!@#"
end subroutine alt_return_spec14
#endif

#ifndef STRICT_F18
subroutine specifiers15(a,b,x)
  integer x
  OPEN (10, file="myfile.dat", err=100)
  READ (10,20,end=200,size=x,advance='no',eor=300) a
  goto 99
99 CLOSE (10)
  goto 40
100 print *,"error opening"
101 return
200 print *,"end of file"
202 return
300 print *, "end of record"
303 return
20 FORMAT (1x,F5.1)
30 FORMAT (2x,F6.2)
40 OPEN (11, file="myfile2.dat", err=100)
  goto 50
50 WRITE (11,30,err=100) b
  CLOSE (11)
end subroutine specifiers15
#endif

#if !defined(STRICT_F18) && defined(ARCHAIC_FORTRAN)
! assigned goto was deleted in F95. PGI supports, gfortran gives warnings
subroutine assigned_goto16
  assign 10 to i
  goto i (10, 20, 30)
10 continue
  assign 20 to i
20 continue
  assign 30 to i
30 pause
  print *, "archaic feature!"
end subroutine assigned_goto16
#endif