2 ! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
5 ! Check the basic semantics of the ASSOCIATE construct.
10 INTEGER, ALLOCATABLE :: arr(:)
23 ! Simple association to expressions.
24 ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b)
26 IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) CALL abort ()
27 IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
30 ! Test association to arrays.
33 ASSOCIATE (doubled => 2 * arr, xyz => func ())
34 IF (SIZE (doubled) /= SIZE (arr)) CALL abort ()
35 IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
38 IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
41 ! Target is vector-indexed.
42 ASSOCIATE (foo => arr((/ 3, 1 /)))
43 IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
44 IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
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) CALL abort ()
52 END ASSOCIATE myname ! Matching end-label.
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) CALL abort ()
57 ASSOCIATE (x => 1 * y, y => 1 * x)
58 IF (x /= 2 .OR. y /= 1) CALL abort ()
62 ! Association to variables.
65 ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
66 IF (x /= 2) CALL abort ()
67 IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
69 IF (y(1, 2) /= 5) CALL abort ()
74 IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
76 ! Association to derived type and component.
78 ASSOCIATE (x => tp, y => tp%comp)
79 IF (x%comp /= 1) CALL abort ()
80 IF (y /= 1) CALL abort ()
82 IF (x%comp /= 5) CALL abort ()
84 IF (tp%comp /= 5) CALL abort ()
86 ! Association to character variables.
96 ! Test association to character variable with automatic length.
97 SUBROUTINE test_char (n)
98 INTEGER, INTENT(IN) :: n
100 CHARACTER(LEN=n) :: str
103 ASSOCIATE (my => str)
104 IF (LEN (my) /= n) CALL abort ()
105 IF (my /= "fooba") CALL abort ()
108 IF (str /= "abcde") CALL abort ()
109 END SUBROUTINE test_char