! { dg-do compile }
|
! { dg-do compile }
|
|
|
! PR fortran/41177
|
! PR fortran/41177
|
! Test for additional errors with type-bound procedure bindings.
|
! Test for additional errors with type-bound procedure bindings.
|
! Namely that non-scalar base objects are rejected for TBP calls which are
|
! Namely that non-scalar base objects are rejected for TBP calls which are
|
! NOPASS, and that passed-object dummy arguments must be scalar, non-POINTER
|
! NOPASS, and that passed-object dummy arguments must be scalar, non-POINTER
|
! and non-ALLOCATABLE.
|
! and non-ALLOCATABLE.
|
|
|
MODULE m
|
MODULE m
|
IMPLICIT NONE
|
IMPLICIT NONE
|
|
|
TYPE t
|
TYPE t
|
CONTAINS
|
CONTAINS
|
PROCEDURE, NOPASS :: myproc
|
PROCEDURE, NOPASS :: myproc
|
END TYPE t
|
END TYPE t
|
|
|
TYPE t2
|
TYPE t2
|
CONTAINS
|
CONTAINS
|
PROCEDURE, PASS :: nonscalar ! { dg-error "must be scalar" }
|
PROCEDURE, PASS :: nonscalar ! { dg-error "must be scalar" }
|
PROCEDURE, PASS :: is_pointer ! { dg-error "must not be POINTER" }
|
PROCEDURE, PASS :: is_pointer ! { dg-error "must not be POINTER" }
|
PROCEDURE, PASS :: is_allocatable ! { dg-error "must not be ALLOCATABLE" }
|
PROCEDURE, PASS :: is_allocatable ! { dg-error "must not be ALLOCATABLE" }
|
END TYPE t2
|
END TYPE t2
|
|
|
CONTAINS
|
CONTAINS
|
|
|
SUBROUTINE myproc ()
|
SUBROUTINE myproc ()
|
END SUBROUTINE myproc
|
END SUBROUTINE myproc
|
|
|
SUBROUTINE nonscalar (me)
|
SUBROUTINE nonscalar (me)
|
CLASS(t2), INTENT(IN) :: me(:)
|
CLASS(t2), INTENT(IN) :: me(:)
|
END SUBROUTINE nonscalar
|
END SUBROUTINE nonscalar
|
|
|
SUBROUTINE is_pointer (me)
|
SUBROUTINE is_pointer (me)
|
CLASS(t2), POINTER, INTENT(IN) :: me
|
CLASS(t2), POINTER, INTENT(IN) :: me
|
END SUBROUTINE is_pointer
|
END SUBROUTINE is_pointer
|
|
|
SUBROUTINE is_allocatable (me)
|
SUBROUTINE is_allocatable (me)
|
CLASS(t2), ALLOCATABLE, INTENT(IN) :: me
|
CLASS(t2), ALLOCATABLE, INTENT(IN) :: me
|
END SUBROUTINE is_allocatable
|
END SUBROUTINE is_allocatable
|
|
|
SUBROUTINE test ()
|
SUBROUTINE test ()
|
TYPE(t) :: arr(2)
|
TYPE(t) :: arr(2)
|
CALL arr%myproc () ! { dg-error "must be scalar" }
|
CALL arr%myproc () ! { dg-error "must be scalar" }
|
END SUBROUTINE test
|
END SUBROUTINE test
|
|
|
END MODULE m
|
END MODULE m
|
|
|
! { dg-final { cleanup-modules "m" } }
|
! { dg-final { cleanup-modules "m" } }
|
|
|
