gcc/testsuite/gfortran.dg/associate_1.f03

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
   3
   4 ! PR fortran/38936
   5 ! Check the basic semantics of the ASSOCIATE construct.
   6
   7 PROGRAM 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) CALL abort ()
  27     IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
  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)) CALL abort ()
  35     IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
  36       CALL abort ()
  37
  38     IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
  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) CALL abort ()
  44     IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
  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) CALL abort ()
  51     END ASSOCIATE
  52   END ASSOCIATE myname ! Matching end-label.
  53
  54   ! Correct behaviour 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 ()
  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) CALL abort ()
  67     IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
  68       CALL abort ()
  69     IF (y(1, 2) /= 5) CALL abort ()
  70
  71     x = 7
  72     y = 8
  73   END ASSOCIATE
  74   IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
  75
  76   ! Association to derived type and component.
  77   tp = myt (1)
  78   ASSOCIATE (x => tp, y => tp%comp)
  79     ! FIXME: Parsing of derived-type associate names, tests with x.
  80     IF (y /= 1) CALL abort ()
  81     y = 5
  82   END ASSOCIATE
  83   IF (tp%comp /= 5) CALL abort ()
  84
  85   ! Association to character variables.
  86   ! FIXME: Enable character test, once this works.
  87   !CALL test_char (5)
  88
  89 CONTAINS
  90
  91   FUNCTION func ()
  92     INTEGER :: func(3)
  93     func = (/ 1, 3, 5 /)
  94   END FUNCTION func
  95
  96 #if 0
  97   ! Test association to character variable with automatic length.
  98   SUBROUTINE test_char (n)
  99     INTEGER, INTENT(IN) :: n
 100
 101     CHARACTER(LEN=n) :: str
 102
 103     str = "foobar"
 104     ASSOCIATE (my => str)
 105       IF (LEN (my) /= n) CALL abort ()
 106       IF (my /= "fooba") CALL abort ()
 107       my = "abcdef"
 108     END ASSOCIATE
 109     IF (str /= "abcde") CALL abort ()
 110   END SUBROUTINE test_char
 111 #endif
 112
 113 END PROGRAM main