URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [substr_4.f] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log


! { dg-do run }
      subroutine test_lower
      implicit none
      character(3), dimension(3) :: zsymel,zsymelr
      common /xx/ zsymel, zsymelr
      integer :: znsymelr
      zsymel = (/ 'X', 'Y', ' ' /)
      zsymelr= (/ 'X', 'Y', ' ' /)
      znsymelr=2
      call check_zsymel(zsymel,zsymelr,znsymelr)
 
      contains
 
      subroutine check_zsymel(zsymel,zsymelr,znsymelr)
        implicit none
        integer znsymelr, isym
        character(*) zsymel(*),zsymelr(*)
        character(len=80) buf
        zsymel(3)(lenstr(zsymel(3))+1:)='X'
        write (buf,10) (trim(zsymelr(isym)),isym=1,znsymelr)
10      format(3(a,:,','))
        if (trim(buf) /= 'X,Y') call abort
      end subroutine check_zsymel
 
      function lenstr(s)
        character(len=*),intent(in) :: s
        integer :: lenstr
        if (len_trim(s) /= 0) call abort
        lenstr = len_trim(s)
      end function lenstr
 
      end subroutine test_lower
 
      subroutine test_upper
      implicit none
      character(3), dimension(3) :: zsymel,zsymelr
      common /xx/ zsymel, zsymelr
      integer :: znsymelr
      zsymel = (/ 'X', 'Y', ' ' /)
      zsymelr= (/ 'X', 'Y', ' ' /)
      znsymelr=2
      call check_zsymel(zsymel,zsymelr,znsymelr)
 
      contains
 
      subroutine check_zsymel(zsymel,zsymelr,znsymelr)
        implicit none
        integer znsymelr, isym
        character(*) zsymel(*),zsymelr(*)
        character(len=80) buf
        zsymel(3)(:lenstr(zsymel(3))+1)='X'
        write (buf,20) (trim(zsymelr(isym)),isym=1,znsymelr)
20      format(3(a,:,','))
        if (trim(buf) /= 'X,Y') call abort
      end subroutine check_zsymel
 
      function lenstr(s)
        character(len=*),intent(in) :: s
        integer :: lenstr
        if (len_trim(s) /= 0) call abort
        lenstr = len_trim(s)
      end function lenstr
 
      end subroutine test_upper
 
      program test
        call test_lower
        call test_upper
      end program test

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`subroutine test_lower`
3			`implicit none`
4			`character(3), dimension(3) :: zsymel,zsymelr`
5			`common /xx/ zsymel, zsymelr`
6			`integer :: znsymelr`
7			`zsymel = (/ 'X', 'Y', ' ' /)`
8			`zsymelr= (/ 'X', 'Y', ' ' /)`
9			`znsymelr=2`
10			`call check_zsymel(zsymel,zsymelr,znsymelr)`
11
12			`contains`
13
14			`subroutine check_zsymel(zsymel,zsymelr,znsymelr)`
15			`implicit none`
16			`integer znsymelr, isym`
17			`character() zsymel(),zsymelr(*)`
18			`character(len=80) buf`
19			`zsymel(3)(lenstr(zsymel(3))+1:)='X'`
20			`write (buf,10) (trim(zsymelr(isym)),isym=1,znsymelr)`
21			`10 format(3(a,:,','))`
22			`if (trim(buf) /= 'X,Y') call abort`
23			`end subroutine check_zsymel`
24
25			`function lenstr(s)`
26			`character(len=*),intent(in) :: s`
27			`integer :: lenstr`
28			`if (len_trim(s) /= 0) call abort`
29			`lenstr = len_trim(s)`
30			`end function lenstr`
31
32			`end subroutine test_lower`
33
34			`subroutine test_upper`
35			`implicit none`
36			`character(3), dimension(3) :: zsymel,zsymelr`
37			`common /xx/ zsymel, zsymelr`
38			`integer :: znsymelr`
39			`zsymel = (/ 'X', 'Y', ' ' /)`
40			`zsymelr= (/ 'X', 'Y', ' ' /)`
41			`znsymelr=2`
42			`call check_zsymel(zsymel,zsymelr,znsymelr)`
43
44			`contains`
45
46			`subroutine check_zsymel(zsymel,zsymelr,znsymelr)`
47			`implicit none`
48			`integer znsymelr, isym`
49			`character() zsymel(),zsymelr(*)`
50			`character(len=80) buf`
51			`zsymel(3)(:lenstr(zsymel(3))+1)='X'`
52			`write (buf,20) (trim(zsymelr(isym)),isym=1,znsymelr)`
53			`20 format(3(a,:,','))`
54			`if (trim(buf) /= 'X,Y') call abort`
55			`end subroutine check_zsymel`
56
57			`function lenstr(s)`
58			`character(len=*),intent(in) :: s`
59			`integer :: lenstr`
60			`if (len_trim(s) /= 0) call abort`
61			`lenstr = len_trim(s)`
62			`end function lenstr`
63
64			`end subroutine test_upper`
65
66			`program test`
67			`call test_lower`
68			`call test_upper`
69			`end program test`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [substr_4.f] - Blame information for rev 801