1! RUN: %S/test_errors.sh %s %t %f18
2! Test 15.7 (C1583-C1590, C1592-C1599) constraints and restrictions
3! for pure procedures.
4! (C1591 is tested in call11.f90; C1594 in call12.f90.)
5
6module m
7
8  type :: impureFinal
9   contains
10    final :: impure
11  end type
12  type :: t
13  end type
14  type :: polyAlloc
15    class(t), allocatable :: a
16  end type
17
18  real, volatile, target :: volatile
19
20 contains
21
22  subroutine impure(x)
23    type(impureFinal) :: x
24  end subroutine
25  integer impure function notpure(n)
26    integer, value :: n
27    notpure = n
28  end function
29
30  pure real function f01(a)
31    real, intent(in) :: a ! ok
32  end function
33  pure real function f02(a)
34    real, value :: a ! ok
35  end function
36  pure real function f03(a) ! C1583
37    !ERROR: non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE
38    real :: a
39  end function
40  pure real function f03a(a)
41    real, pointer :: a ! ok
42  end function
43  pure real function f04(a) ! C1583
44    !ERROR: non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE
45    real, intent(out) :: a
46  end function
47  pure real function f04a(a)
48    real, pointer, intent(out) :: a ! ok if pointer
49  end function
50  pure real function f05(a) ! C1583
51    real, value :: a ! weird, but ok (VALUE without INTENT)
52  end function
53  pure function f06() ! C1584
54    !ERROR: Result of pure function may not have an impure FINAL subroutine
55    type(impureFinal) :: f06
56  end function
57  pure function f07() ! C1585
58    !ERROR: Result of pure function may not be both polymorphic and ALLOCATABLE
59    class(t), allocatable :: f07
60  end function
61  pure function f08() ! C1585
62    !ERROR: Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%a'
63    type(polyAlloc) :: f08
64  end function
65
66  pure subroutine s01(a) ! C1586
67    !ERROR: non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute
68    real :: a
69  end subroutine
70  pure subroutine s01a(a)
71    real, pointer :: a
72  end subroutine
73  pure subroutine s02(a) ! C1587
74    !ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine
75    type(impureFinal), intent(out) :: a
76  end subroutine
77  pure subroutine s03(a) ! C1588
78    !ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic
79    class(t), intent(out) :: a
80  end subroutine
81  pure subroutine s04(a) ! C1588
82    !ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component
83    type(polyAlloc), intent(out) :: a
84  end subroutine
85  pure subroutine s05 ! C1589
86    !ERROR: A pure subprogram may not have a variable with the SAVE attribute
87    real, save :: v1
88    !ERROR: A pure subprogram may not have a variable with the SAVE attribute
89    real :: v2 = 0.
90    !TODO: once we have DATA: !ERROR: A pure subprogram may not have a variable with the SAVE attribute
91    real :: v3
92    data v3/0./
93    !ERROR: A pure subprogram may not have a variable with the SAVE attribute
94    real :: v4
95    common /blk/ v4
96    save /blk/
97    block
98    !ERROR: A pure subprogram may not have a variable with the SAVE attribute
99      real, save :: v5
100    !ERROR: A pure subprogram may not have a variable with the SAVE attribute
101      real :: v6 = 0.
102    end block
103  end subroutine
104  pure subroutine s06 ! C1589
105    !ERROR: A pure subprogram may not have a variable with the VOLATILE attribute
106    real, volatile :: v1
107    block
108    !ERROR: A pure subprogram may not have a variable with the VOLATILE attribute
109      real, volatile :: v2
110    end block
111  end subroutine
112  pure subroutine s07(p) ! C1590
113    !ERROR: A dummy procedure of a pure subprogram must be pure
114    procedure(impure) :: p
115  end subroutine
116  ! C1591 is tested in call11.f90.
117  pure subroutine s08 ! C1592
118   contains
119    pure subroutine pure ! ok
120    end subroutine
121    !ERROR: An internal subprogram of a pure subprogram must also be pure
122    subroutine impure1
123    end subroutine
124    !ERROR: An internal subprogram of a pure subprogram must also be pure
125    impure subroutine impure2
126    end subroutine
127  end subroutine
128  pure subroutine s09 ! C1593
129    real :: x
130    !ERROR: VOLATILE variable 'volatile' may not be referenced in pure subprogram 's09'
131    x = volatile
132  end subroutine
133  ! C1594 is tested in call12.f90.
134  pure subroutine s10 ! C1595
135    integer :: n
136    !ERROR: Procedure 'notpure' referenced in pure subprogram 's10' must be pure too
137    n = notpure(1)
138  end subroutine
139  pure subroutine s11(to) ! C1596
140    ! Implicit deallocation at the end of the subroutine
141    !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram
142    type(polyAlloc) :: auto
143    type(polyAlloc), intent(in out) :: to
144    !ERROR: Deallocation of polymorphic non-coarray component '%a' is not permitted in a pure subprogram
145    to = auto
146  end subroutine
147  pure subroutine s12
148    character(20) :: buff
149    real :: x
150    write(buff, *) 1.0 ! ok
151    read(buff, *) x ! ok
152    !ERROR: External I/O is not allowed in a pure subprogram
153    print *, 'hi' ! C1597
154    !ERROR: External I/O is not allowed in a pure subprogram
155    open(1, file='launch-codes') ! C1597
156    !ERROR: External I/O is not allowed in a pure subprogram
157    close(1) ! C1597
158    !ERROR: External I/O is not allowed in a pure subprogram
159    backspace(1) ! C1597
160    !Also checks parsing of variant END FILE spelling
161    !ERROR: External I/O is not allowed in a pure subprogram
162    end file(1) ! C1597
163    !ERROR: External I/O is not allowed in a pure subprogram
164    rewind(1) ! C1597
165    !ERROR: External I/O is not allowed in a pure subprogram
166    flush(1) ! C1597
167    !ERROR: External I/O is not allowed in a pure subprogram
168    wait(1) ! C1597
169    !ERROR: External I/O is not allowed in a pure subprogram
170    inquire(1, name=buff) ! C1597
171    !ERROR: External I/O is not allowed in a pure subprogram
172    read(5, *) x ! C1598
173    !ERROR: External I/O is not allowed in a pure subprogram
174    read(*, *) x ! C1598
175    !ERROR: External I/O is not allowed in a pure subprogram
176    write(6, *) ! C1598
177    !ERROR: External I/O is not allowed in a pure subprogram
178    write(*, *) ! C1598
179  end subroutine
180  pure subroutine s13
181    !ERROR: An image control statement may not appear in a pure subprogram
182    sync all ! C1599
183  end subroutine
184  pure subroutine s14
185    integer :: img, nimgs, i[*], tmp
186                                   ! implicit sync all
187    !ERROR: Procedure 'this_image' referenced in pure subprogram 's14' must be pure too
188    img = this_image()
189    nimgs = num_images()
190    i = img                       ! i is ready to use
191
192    if ( img .eq. 1 ) then
193      !ERROR: An image control statement may not appear in a pure subprogram
194      sync images( nimgs )          ! explicit sync 1 with last img
195      tmp = i[ nimgs ]
196      !ERROR: An image control statement may not appear in a pure subprogram
197      sync images( nimgs )          ! explicit sync 2 with last img
198      i = tmp
199    end if
200
201    if ( img .eq. nimgs ) then
202      !ERROR: An image control statement may not appear in a pure subprogram
203      sync images( 1 )              ! explicit sync 1 with img 1
204      tmp = i[ 1 ]
205      !ERROR: An image control statement may not appear in a pure subprogram
206      sync images( 1 )              ! explicit sync 2 with img 1
207      i = tmp
208    end if
209    !ERROR: External I/O is not allowed in a pure subprogram
210    write (*,*) img, i
211                                   ! all other images wait here
212    ! TODO others from 11.6.1 (many)
213  end subroutine
214end module
215