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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [impure_1.f08] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
! { dg-options "-std=f2008 -fall-intrinsics" }
3
 
4
! PR fortran/45197
5
! Check that IMPURE and IMPURE ELEMENTAL in particular works.
6
 
7
! Contributed by Daniel Kraft, d@domob.eu.
8
 
9
MODULE m
10
  IMPLICIT NONE
11
 
12
  INTEGER, PARAMETER :: n = 5
13
 
14
  INTEGER :: i
15
  INTEGER :: arr(n)
16
 
17
CONTAINS
18
 
19
  ! This ought to work (without any effect).
20
  IMPURE SUBROUTINE foobar ()
21
  END SUBROUTINE foobar
22
 
23
  IMPURE ELEMENTAL SUBROUTINE impureSub (a)
24
    INTEGER, INTENT(IN) :: a
25
 
26
    arr(i) = a
27
    i = i + 1
28
 
29
    PRINT *, a
30
  END SUBROUTINE impureSub
31
 
32
END MODULE m
33
 
34
PROGRAM main
35
  USE :: m
36
  IMPLICIT NONE
37
 
38
  INTEGER :: a(n), b(n), s
39
 
40
  a = (/ (i, i = 1, n) /)
41
 
42
  ! Traverse in forward order.
43
  s = 0
44
  b = accumulate (a, s)
45
  IF (ANY (b /= (/ 1, 3, 6, 10, 15 /))) CALL abort ()
46
 
47
  ! And now backward.
48
  s = 0
49
  b = accumulate (a(n:1:-1), s)
50
  IF (ANY (b /= (/ 5, 9, 12, 14, 15 /))) CALL abort ()
51
 
52
  ! Use subroutine.
53
  i = 1
54
  arr = 0
55
  CALL impureSub (a)
56
  IF (ANY (arr /= a)) CALL abort ()
57
 
58
CONTAINS
59
 
60
  IMPURE ELEMENTAL FUNCTION accumulate (a, s)
61
    INTEGER, INTENT(IN) :: a
62
    INTEGER, INTENT(INOUT) :: s
63
    INTEGER :: accumulate
64
 
65
    s = s + a
66
    accumulate = s
67
  END FUNCTION accumulate
68
 
69
END PROGRAM main
70
 
71
! { dg-final { cleanup-modules "m" } }

powered by: WebSVN 2.1.0

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