gcc/testsuite/gfortran.dg/pointer_check_6.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=pointer" }
   3 !
   4 ! { dg-shouldfail "pointer check" }
   5 ! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" }
   6 !
   7 ! PR fortran/40604
   8 !
   9 ! The following cases are all valid, but were failing
  10 ! for one or the other reason.
  11 !
  12 ! Contributed by Janus Weil and Tobias Burnus.
  13 !
  14
  15 subroutine test1()
  16   call test(uec=-1)
  17 contains
  18   subroutine test(str,uec)
  19     implicit none
  20     character*(*), intent(in), optional:: str
  21     integer, intent(in), optional :: uec
  22   end subroutine
  23 end subroutine test1
  24
  25 module m
  26   interface matrixMult
  27      Module procedure matrixMult_C2
  28   End Interface
  29 contains
  30   subroutine test
  31     implicit none
  32     complex, dimension(0:3,0:3) :: m1,m2
  33     print *,Trace(MatrixMult(m1,m2))
  34   end subroutine
  35   complex function trace(a)
  36     implicit none
  37     complex, intent(in),  dimension(0:3,0:3) :: a
  38   end function trace
  39   function matrixMult_C2(a,b) result(matrix)
  40     implicit none
  41     complex, dimension(0:3,0:3) :: matrix,a,b
  42   end function matrixMult_C2
  43 end module m
  44
  45 SUBROUTINE plotdop(amat)
  46       IMPLICIT NONE
  47       REAL,    INTENT (IN) :: amat(3,3)
  48       integer :: i1
  49       real :: pt(3)
  50       i1 = 1
  51       pt = MATMUL(amat,(/i1,i1,i1/))
  52 END SUBROUTINE plotdop
  53
  54         FUNCTION evaluateFirst(s,n)result(number)
  55           IMPLICIT NONE
  56           CHARACTER(len =*), INTENT(inout) :: s
  57           INTEGER,OPTIONAL                 :: n
  58           REAL                             :: number
  59           number = 1.1
  60         end function
  61
  62 SUBROUTINE rw_inp(scpos)
  63       IMPLICIT NONE
  64       REAL scpos
  65
  66       interface
  67         FUNCTION evaluateFirst(s,n)result(number)
  68           IMPLICIT NONE
  69           CHARACTER(len =*), INTENT(inout) :: s
  70           INTEGER,OPTIONAL                 :: n
  71           REAL                             :: number
  72         end function
  73       end interface
  74
  75       CHARACTER(len=100) :: line
  76       scpos = evaluatefirst(line)
  77 END SUBROUTINE rw_inp
  78
  79 program test
  80   integer, pointer :: a
  81 !  nullify(a)
  82   allocate(a)
  83   a = 1
  84   call sub1a(a)
  85   call sub1b(a)
  86   call sub1c()
  87 contains
  88   subroutine sub1a(a)
  89    integer, pointer :: a
  90    call sub2(a)
  91    call sub3(a)
  92    call sub4(a)
  93   end subroutine sub1a
  94   subroutine sub1b(a)
  95    integer, pointer,optional :: a
  96    call sub2(a)
  97    call sub3(a)
  98    call sub4(a)
  99   end subroutine sub1b
 100   subroutine sub1c(a)
 101    integer, pointer,optional :: a
 102    call sub4(a)
 103 !   call sub2(a)  ! << Invalid - working correctly, but not allowed in F2003
 104    call sub3(a) ! << INVALID
 105   end subroutine sub1c
 106   subroutine sub4(b)
 107     integer, optional,pointer :: b
 108   end subroutine
 109   subroutine sub2(b)
 110     integer, optional :: b
 111   end subroutine
 112   subroutine sub3(b)
 113     integer :: b
 114   end subroutine
 115 end
 116
 117
 118 ! { dg-final { cleanup-modules "m" } }