1! { dg-do run }
2! { dg-options "-std=f2003  -cpp" }
3
4! PR fortran/38936
5! Check the basic semantics of the ASSOCIATE construct.
6
7PROGRAM main
8  IMPLICIT NONE
9  REAL :: a, b, c
10  INTEGER, ALLOCATABLE :: arr(:)
11  INTEGER :: mat(3, 3)
12
13  TYPE :: myt
14    INTEGER :: comp
15  END TYPE myt
16
17  TYPE(myt) :: tp
18
19  a = -2.0
20  b = 3.0
21  c = 4.0
22
23  ! Simple association to expressions.
24  ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b)
25    PRINT *, t, a, b
26    IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) STOP 1
27    IF (ABS (t - a - b) > 1.0e-3) STOP 2
28  END ASSOCIATE
29
30  ! Test association to arrays.
31  ALLOCATE (arr(3))
32  arr = (/ 1, 2, 3 /)
33  ASSOCIATE (doubled => 2 * arr, xyz => func ())
34    IF (SIZE (doubled) /= SIZE (arr)) STOP 3
35    IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
36      STOP 4
37
38    IF (ANY (xyz /= (/ 1, 3, 5 /))) STOP 5
39  END ASSOCIATE
40
41  ! Target is vector-indexed.
42  ASSOCIATE (foo => arr((/ 3, 1 /)))
43    IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) STOP 6
44    IF (foo(1) /= 3 .OR. foo(2) /= 1) STOP 7
45  END ASSOCIATE
46
47  ! Named and nested associate.
48  myname: ASSOCIATE (x => a - b * c)
49    ASSOCIATE (y => 2.0 * x)
50      IF (ABS (y - 2.0 * (a - b * c)) > 1.0e-3) STOP 8
51    END ASSOCIATE
52  END ASSOCIATE myname ! Matching end-label.
53
54  ! Correct behavior when shadowing already existing names.
55  ASSOCIATE (a => 1 * b, b => 1 * a, x => 1, y => 2)
56    IF (ABS (a - 3.0) > 1.0e-3 .OR. ABS (b + 2.0) > 1.0e-3) STOP 9
57    ASSOCIATE (x => 1 * y, y => 1 * x)
58      IF (x /= 2 .OR. y /= 1) STOP 10
59    END ASSOCIATE
60  END ASSOCIATE
61
62  ! Association to variables.
63  mat = 0
64  mat(2, 2) = 5;
65  ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
66    IF (x /= 2) STOP 11
67    IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
68      STOP 12
69    IF (y(1, 2) /= 5) STOP 13
70
71    x = 7
72    y = 8
73  END ASSOCIATE
74  IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) STOP 14
75
76  ! Association to derived type and component.
77  tp = myt (1)
78  ASSOCIATE (x => tp, y => tp%comp)
79    IF (x%comp /= 1) STOP 15
80    IF (y /= 1) STOP 16
81    y = 5
82    IF (x%comp /= 5) STOP 17
83  END ASSOCIATE
84  IF (tp%comp /= 5) STOP 18
85
86  ! Association to character variables.
87  CALL test_char (5)
88
89CONTAINS
90
91  FUNCTION func ()
92    INTEGER :: func(3)
93    func = (/ 1, 3, 5 /)
94  END FUNCTION func
95
96  ! Test association to character variable with automatic length.
97  SUBROUTINE test_char (n)
98    INTEGER, INTENT(IN) :: n
99
100    CHARACTER(LEN=n) :: str
101
102    str = "foobar"
103    ASSOCIATE (my => str)
104      IF (LEN (my) /= n) STOP 19
105      IF (my /= "fooba") STOP 20
106      my = "abcdef"
107    END ASSOCIATE
108    IF (str /= "abcde") STOP 21
109  END SUBROUTINE test_char
110
111END PROGRAM main
112