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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [where_operator_assign_2.f90] - Blame information for rev 154

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

Line No. Rev Author Line
1 149 jeremybenn
! { dg-do compile }
2
! Tests the fix for PR30407, in which operator assignments did not work
3
! in WHERE blocks or simple WHERE statements.
4
!
5
! Contributed by Paul Thomas 
6
!******************************************************************************
7
module global
8
  type :: a
9
    integer :: b
10
    integer :: c
11
  end type a
12
  interface assignment(=)
13
    module procedure a_to_a
14
  end interface
15
  interface operator(.ne.)
16
    module procedure a_ne_a
17
  end interface
18
 
19
  type(a) :: x(4), y(4), z(4), u(4, 4)
20
  logical :: l1(4), t = .true., f= .false.
21
contains
22
!******************************************************************************
23
  elemental subroutine a_to_a (m, n)
24
    type(a), intent(in) :: n
25
    type(a), intent(out) :: m
26
    m%b = n%b + 1
27
    m%c = n%c
28
  end subroutine a_to_a
29
!******************************************************************************
30
  elemental logical function a_ne_a (m, n)
31
    type(a), intent(in) :: n
32
    type(a), intent(in) :: m
33
    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
34
  end function a_ne_a
35
!******************************************************************************
36
  elemental function foo (m)
37
    type(a) :: foo
38
    type(a), intent(in) :: m
39
    foo%b = 0
40
    foo%c = m%c
41
  end function foo
42
end module global
43
!******************************************************************************
44
program test
45
  use global
46
  x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
47
  y = x
48
  z = x
49
  l1 = (/t, f, f, t/)
50
 
51
  call test_where_1
52
  if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
53
 
54
  call test_where_2
55
  if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort ()
56
  if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort ()
57
 
58
  call test_where_3
59
  if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
60
 
61
  y = x
62
  call test_where_forall_1
63
  if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort ()
64
 
65
  l1 = (/t, f, t, f/)
66
  call test_where_4
67
  if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
68
 
69
contains
70
!******************************************************************************
71
  subroutine test_where_1        ! Test a simple WHERE
72
    where (l1) y = x
73
  end subroutine test_where_1
74
!******************************************************************************
75
  subroutine test_where_2        ! Test a WHERE blocks
76
    where (l1)
77
      y = a (0, 0)
78
      z = z(4:1:-1)
79
    elsewhere
80
      y = x
81
      z = a (0, 0)
82
    end where
83
  end subroutine test_where_2
84
!******************************************************************************
85
  subroutine test_where_3        ! Test a simple WHERE with a function assignment
86
    where (.not. l1) y = foo (x)
87
  end subroutine test_where_3
88
!******************************************************************************
89
  subroutine test_where_forall_1 ! Test a WHERE in a FORALL block
90
    forall (i = 1:4)
91
      where (.not. l1)
92
        u(i, :) = x
93
      elsewhere
94
        u(i, :) = a(0, i)
95
      endwhere
96
    end forall
97
  end subroutine test_where_forall_1
98
!******************************************************************************
99
  subroutine test_where_4       ! Test a WHERE assignment with dependencies
100
    where (l1(1:3))
101
      x(2:4) = x(1:3)
102
    endwhere
103
  end subroutine test_where_4
104
end program test
105
! { dg-final { cleanup-modules "global" } }
106
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.