summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/pointer_check_6.f90
blob: 2f7373fe6ba2e39a80b927239f89e179b50107d7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
! { dg-do run }
! { dg-options "-fcheck=pointer" }
!
! { dg-shouldfail "pointer check" }
! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" }
!
! PR fortran/40604
!
! The following cases are all valid, but were failing
! for one or the other reason.
!
! Contributed by Janus Weil and Tobias Burnus.
!

subroutine test1()
  call test(uec=-1)
contains 
  subroutine test(str,uec)
    implicit none
    character*(*), intent(in), optional:: str
    integer, intent(in), optional :: uec
  end subroutine
end subroutine test1

module m
  interface matrixMult
     Module procedure matrixMult_C2
  End Interface
contains
  subroutine test
    implicit none
    complex, dimension(0:3,0:3) :: m1,m2
    print *,Trace(MatrixMult(m1,m2))
  end subroutine
  complex function trace(a)
    implicit none
    complex, intent(in),  dimension(0:3,0:3) :: a 
  end function trace
  function matrixMult_C2(a,b) result(matrix)
    implicit none
    complex, dimension(0:3,0:3) :: matrix,a,b
  end function matrixMult_C2
end module m

SUBROUTINE plotdop(amat)
      IMPLICIT NONE
      REAL,    INTENT (IN) :: amat(3,3)
      integer :: i1
      real :: pt(3)
      i1 = 1
      pt = MATMUL(amat,(/i1,i1,i1/))
END SUBROUTINE plotdop

        FUNCTION evaluateFirst(s,n)result(number)
          IMPLICIT NONE
          CHARACTER(len =*), INTENT(inout) :: s
          INTEGER,OPTIONAL                 :: n
          REAL                             :: number
          number = 1.1
        end function

SUBROUTINE rw_inp(scpos)
      IMPLICIT NONE
      REAL scpos

      interface
        FUNCTION evaluateFirst(s,n)result(number)
          IMPLICIT NONE
          CHARACTER(len =*), INTENT(inout) :: s
          INTEGER,OPTIONAL                 :: n
          REAL                             :: number
        end function
      end interface

      CHARACTER(len=100) :: line
      scpos = evaluatefirst(line)
END SUBROUTINE rw_inp

program test
  integer, pointer :: a
!  nullify(a)
  allocate(a)
  a = 1
  call sub1a(a)
  call sub1b(a)
  call sub1c()
contains
  subroutine sub1a(a)
   integer, pointer :: a
   call sub2(a)
   call sub3(a)
   call sub4(a)
  end subroutine sub1a
  subroutine sub1b(a)
   integer, pointer,optional :: a
   call sub2(a)
   call sub3(a)
   call sub4(a)
  end subroutine sub1b
  subroutine sub1c(a)
   integer, pointer,optional :: a
   call sub4(a)
!   call sub2(a)  ! << Invalid - working correctly, but not allowed in F2003
   call sub3(a) ! << INVALID
  end subroutine sub1c
  subroutine sub4(b)
    integer, optional,pointer :: b
  end subroutine
  subroutine sub2(b)
    integer, optional :: b
  end subroutine
  subroutine sub3(b)
    integer :: b
  end subroutine
end


! { dg-final { cleanup-modules "m" } }