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