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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log


! { dg-do run }
! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
 
! PR fortran/38936
! Check the basic semantics of the ASSOCIATE construct.
 
PROGRAM main
  IMPLICIT NONE
  REAL :: a, b, c
  INTEGER, ALLOCATABLE :: arr(:)
  INTEGER :: mat(3, 3)
 
  TYPE :: myt
    INTEGER :: comp
  END TYPE myt
 
  TYPE(myt) :: tp
 
  a = -2.0
  b = 3.0
  c = 4.0
 
  ! Simple association to expressions.
  ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b)
    PRINT *, t, a, b
    IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) CALL abort ()
    IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
  END ASSOCIATE
 
  ! Test association to arrays.
  ALLOCATE (arr(3))
  arr = (/ 1, 2, 3 /)
  ASSOCIATE (doubled => 2 * arr, xyz => func ())
    IF (SIZE (doubled) /= SIZE (arr)) CALL abort ()
    IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
      CALL abort ()
 
    IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
  END ASSOCIATE
 
  ! Target is vector-indexed.
  ASSOCIATE (foo => arr((/ 3, 1 /)))
    IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
    IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
  END ASSOCIATE
 
  ! Named and nested associate.
  myname: ASSOCIATE (x => a - b * c)
    ASSOCIATE (y => 2.0 * x)
      IF (ABS (y - 2.0 * (a - b * c)) > 1.0e-3) CALL abort ()
    END ASSOCIATE
  END ASSOCIATE myname ! Matching end-label.
 
  ! Correct behaviour when shadowing already existing names.
  ASSOCIATE (a => 1 * b, b => 1 * a, x => 1, y => 2)
    IF (ABS (a - 3.0) > 1.0e-3 .OR. ABS (b + 2.0) > 1.0e-3) CALL abort ()
    ASSOCIATE (x => 1 * y, y => 1 * x)
      IF (x /= 2 .OR. y /= 1) CALL abort ()
    END ASSOCIATE
  END ASSOCIATE
 
  ! Association to variables.
  mat = 0
  mat(2, 2) = 5;
  ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
    IF (x /= 2) CALL abort ()
    IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
      CALL abort ()
    IF (y(1, 2) /= 5) CALL abort ()
 
    x = 7
    y = 8
  END ASSOCIATE
  IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
 
  ! Association to derived type and component.
  tp = myt (1)
  ASSOCIATE (x => tp, y => tp%comp)
    IF (x%comp /= 1) CALL abort ()
    IF (y /= 1) CALL abort ()
    y = 5
    IF (x%comp /= 5) CALL abort ()
  END ASSOCIATE
  IF (tp%comp /= 5) CALL abort ()
 
  ! Association to character variables.
  ! FIXME: Enable character test, once this works.
  !CALL test_char (5)
 
CONTAINS
 
  FUNCTION func ()
    INTEGER :: func(3)
    func = (/ 1, 3, 5 /)
  END FUNCTION func
 
#if 0
  ! Test association to character variable with automatic length.
  SUBROUTINE test_char (n)
    INTEGER, INTENT(IN) :: n
 
    CHARACTER(LEN=n) :: str
 
    str = "foobar"
    ASSOCIATE (my => str)
      IF (LEN (my) /= n) CALL abort ()
      IF (my /= "fooba") CALL abort ()
      my = "abcdef"
    END ASSOCIATE
    IF (str /= "abcde") CALL abort ()
  END SUBROUTINE test_char
#endif
 
END PROGRAM main

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { 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 (a2 + b2 + 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			`IF (x%comp /= 1) CALL abort ()`
80			`IF (y /= 1) CALL abort ()`
81			`y = 5`
82			`IF (x%comp /= 5) CALL abort ()`
83			`END ASSOCIATE`
84			`IF (tp%comp /= 5) CALL abort ()`
85
86			`! Association to character variables.`
87			`! FIXME: Enable character test, once this works.`
88			`!CALL test_char (5)`
89
90			`CONTAINS`
91
92			`FUNCTION func ()`
93			`INTEGER :: func(3)`
94			`func = (/ 1, 3, 5 /)`
95			`END FUNCTION func`
96
97			`#if 0`
98			`! Test association to character variable with automatic length.`
99			`SUBROUTINE test_char (n)`
100			`INTEGER, INTENT(IN) :: n`
101
102			`CHARACTER(LEN=n) :: str`
103
104			`str = "foobar"`
105			`ASSOCIATE (my => str)`
106			`IF (LEN (my) /= n) CALL abort ()`
107			`IF (my /= "fooba") CALL abort ()`
108			`my = "abcdef"`
109			`END ASSOCIATE`
110			`IF (str /= "abcde") CALL abort ()`
111			`END SUBROUTINE test_char`
112			`#endif`
113
114			`END PROGRAM main`

Browse

Tools

Subversion Repositories openrisc

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