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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [namelist_14.f90] - Blame information for rev 302

Details | Compare with Previous | View Log


!{ dg-do run }
!{ dg-options "-std=legacy" }
!
! Tests various combinations of intrinsic types, derived types, arrays,
! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
! See comments below for selection.
! provided by Paul Thomas - pault@gcc.gnu.org
 
module global
  type             ::  mt
    sequence
    integer        ::  ii(4)
  end type mt
end module global
 
program namelist_14
  use global
  common /myc/ cdt
  integer          ::  i(2) = (/101,201/)
  type(mt)         ::  dt(2)
  type(mt)         ::  cdt
  real(kind=8)           ::  pi = 3.14159_8
  character*10     ::  chs="singleton"
  character*10     ::  cha(2)=(/"first     ","second    "/)
 
  dt = mt ((/99,999,9999,99999/))
  cdt = mt ((/-99,-999,-9999,-99999/))
  call foo (i,dt,pi,chs,cha)
 
contains
 
  logical function dttest (dt1, dt2)
    use global
    type(mt)       :: dt1
    type(mt)       :: dt2
    dttest = any(dt1%ii == dt2%ii)
  end function dttest
 
 
  subroutine foo (i, dt, pi, chs, cha)
    use global
    common /myc/ cdt
    real(kind=8)        :: pi                   !local real scalar
    integer        :: i(2)                 !dummy arg. array
    integer        :: j(2) = (/21, 21/)    !equivalenced array
    integer        :: jj                   !    -||-     scalar
    integer        :: ier
    type(mt)       :: dt(2)                !dummy arg., derived array
    type(mt)       :: dtl(2)               !in-scope derived type array
    type(mt)       :: dts                  !in-scope derived type
    type(mt)       :: cdt                  !derived type in common block
    character*10   :: chs                  !dummy arg. character var.
    character*10   :: cha(:)               !dummy arg. character array
    character*10   :: chl="abcdefg"        !in-scope character var.
    equivalence (j,jj)
    namelist /z/     dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha
 
    dts = mt ((/1, 2, 3, 4/))
    dtl = mt ((/41, 42, 43, 44/))
 
    open (10, status = "scratch", delim='apostrophe')
    write (10, nml = z, iostat = ier)
    if (ier /= 0 ) call abort()
    rewind (10)
 
    i = 0
    j = 0
    jj = 0
    pi = 0
    dt  = mt ((/0, 0, 0, 0/))
    dtl = mt ((/0, 0, 0, 0/))
    dts = mt ((/0, 0, 0, 0/))
    cdt = mt ((/0, 0, 0, 0/))
    chs = ""
    cha = ""
    chl = ""
 
    read (10, nml = z, iostat = ier)
    if (ier /= 0 ) call abort()
    close (10)
 
    if (.not.(dttest (dt(1),  mt ((/99,999,9999,99999/))) .and.  &
          dttest (dt(2),  mt ((/99,999,9999,99999/))) .and.  &
          dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and.     &
          dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and.     &
          dttest (dts, mt ((/1, 2, 3, 4/))) .and.            &
          dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
          all (j ==(/21, 21/)) .and.                         &
          all (i ==(/101, 201/)) .and.                       &
          (pi == 3.14159_8) .and.                            &
          (chs == "singleton") .and.                         &
          (chl == "abcdefg") .and.                           &
          (cha(1)(1:10) == "first    ") .and.                &
          (cha(2)(1:10) == "second    "))) call abort ()
 
    end subroutine foo
end program namelist_14
 
! { dg-final { cleanup-modules "global" } }

Line No.	Rev	Author	Line
1	302	jeremybenn	`!{ dg-do run }`
2			`!{ dg-options "-std=legacy" }`
3			`!`
4			`! Tests various combinations of intrinsic types, derived types, arrays,`
5			`! dummy arguments and common to check nml_get_addr_expr in trans-io.c.`
6			`! See comments below for selection.`
7			`! provided by Paul Thomas - pault@gcc.gnu.org`
8
9			`module global`
10			`type :: mt`
11			`sequence`
12			`integer :: ii(4)`
13			`end type mt`
14			`end module global`
15
16			`program namelist_14`
17			`use global`
18			`common /myc/ cdt`
19			`integer :: i(2) = (/101,201/)`
20			`type(mt) :: dt(2)`
21			`type(mt) :: cdt`
22			`real(kind=8) :: pi = 3.14159_8`
23			`character*10 :: chs="singleton"`
24			`character*10 :: cha(2)=(/"first ","second "/)`
25
26			`dt = mt ((/99,999,9999,99999/))`
27			`cdt = mt ((/-99,-999,-9999,-99999/))`
28			`call foo (i,dt,pi,chs,cha)`
29
30			`contains`
31
32			`logical function dttest (dt1, dt2)`
33			`use global`
34			`type(mt) :: dt1`
35			`type(mt) :: dt2`
36			`dttest = any(dt1%ii == dt2%ii)`
37			`end function dttest`
38
39
40			`subroutine foo (i, dt, pi, chs, cha)`
41			`use global`
42			`common /myc/ cdt`
43			`real(kind=8) :: pi !local real scalar`
44			`integer :: i(2) !dummy arg. array`
45			`integer :: j(2) = (/21, 21/) !equivalenced array`
46			`integer :: jj ! -\|\|- scalar`
47			`integer :: ier`
48			`type(mt) :: dt(2) !dummy arg., derived array`
49			`type(mt) :: dtl(2) !in-scope derived type array`
50			`type(mt) :: dts !in-scope derived type`
51			`type(mt) :: cdt !derived type in common block`
52			`character*10 :: chs !dummy arg. character var.`
53			`character*10 :: cha(:) !dummy arg. character array`
54			`character*10 :: chl="abcdefg" !in-scope character var.`
55			`equivalence (j,jj)`
56			`namelist /z/ dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha`
57
58			`dts = mt ((/1, 2, 3, 4/))`
59			`dtl = mt ((/41, 42, 43, 44/))`
60
61			`open (10, status = "scratch", delim='apostrophe')`
62			`write (10, nml = z, iostat = ier)`
63			`if (ier /= 0 ) call abort()`
64			`rewind (10)`
65
66			`i = 0`
67			`j = 0`
68			`jj = 0`
69			`pi = 0`
70			`dt = mt ((/0, 0, 0, 0/))`
71			`dtl = mt ((/0, 0, 0, 0/))`
72			`dts = mt ((/0, 0, 0, 0/))`
73			`cdt = mt ((/0, 0, 0, 0/))`
74			`chs = ""`
75			`cha = ""`
76			`chl = ""`
77
78			`read (10, nml = z, iostat = ier)`
79			`if (ier /= 0 ) call abort()`
80			`close (10)`
81
82			`if (.not.(dttest (dt(1), mt ((/99,999,9999,99999/))) .and. &`
83			`dttest (dt(2), mt ((/99,999,9999,99999/))) .and. &`
84			`dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and. &`
85			`dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and. &`
86			`dttest (dts, mt ((/1, 2, 3, 4/))) .and. &`
87			`dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &`
88			`all (j ==(/21, 21/)) .and. &`
89			`all (i ==(/101, 201/)) .and. &`
90			`(pi == 3.14159_8) .and. &`
91			`(chs == "singleton") .and. &`
92			`(chl == "abcdefg") .and. &`
93			`(cha(1)(1:10) == "first ") .and. &`
94			`(cha(2)(1:10) == "second "))) call abort ()`
95
96			`end subroutine foo`
97			`end program namelist_14`
98
99			`! { dg-final { cleanup-modules "global" } }`

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [namelist_14.f90] - Blame information for rev 302