Subversion Repositories openrisc

! { 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" } }