Subversion Repositories openrisc

! { dg-do compile }

! Type-bound procedures

! Test for errors in specific bindings, during resolution.

MODULE othermod

  IMPLICIT NONE

CONTAINS

  REAL FUNCTION proc_noarg ()

    IMPLICIT NONE

  END FUNCTION proc_noarg

END MODULE othermod

MODULE testmod

  USE othermod

  IMPLICIT NONE

  INTEGER :: noproc

  PROCEDURE() :: proc_nointf

  INTERFACE

    SUBROUTINE proc_intf ()

    END SUBROUTINE proc_intf

  END INTERFACE

  ABSTRACT INTERFACE

    SUBROUTINE proc_abstract_intf ()

    END SUBROUTINE proc_abstract_intf

  END INTERFACE

  TYPE supert

  CONTAINS

    PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg

    PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_sub_noarg

  END TYPE supert

  TYPE, EXTENDS(supert) :: t

  CONTAINS

    ! Bindings that should succeed

    PROCEDURE, NOPASS :: p0 => proc_noarg

    PROCEDURE, PASS :: p1 => proc_arg_first

    PROCEDURE proc_arg_first

    PROCEDURE, PASS(me) :: p2 => proc_arg_middle

    PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last

    PROCEDURE, NOPASS :: p4 => proc_nome

    PROCEDURE, NOPASS :: p5 => proc_intf

    PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg

    ! Bindings that should not succeed

    PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|module procedure" }

    PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" }

    PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" }

    PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" }

    PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }

    PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }

    PROCEDURE :: e6 => noproc ! { dg-error "module procedure" }

    PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" }

    PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" }

    PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" }

  END TYPE t

CONTAINS

  SUBROUTINE proc_arg_first (me, x)

    IMPLICIT NONE

    CLASS(t) :: me

    REAL :: x

  END SUBROUTINE proc_arg_first

  INTEGER FUNCTION proc_arg_middle (x, me, y)

    IMPLICIT NONE

    REAL :: x, y

    CLASS(t) :: me

  END FUNCTION proc_arg_middle

  SUBROUTINE proc_arg_last (x, me)

    IMPLICIT NONE

    CLASS(t) :: me

    REAL :: x

  END SUBROUTINE proc_arg_last

  SUBROUTINE proc_nome (arg, x, y)

    IMPLICIT NONE

    TYPE(t) :: arg

    REAL :: x, y

  END SUBROUTINE proc_nome

  SUBROUTINE proc_mewrong (me, x)

    IMPLICIT NONE

    REAL :: x

    INTEGER :: me

  END SUBROUTINE proc_mewrong

  SUBROUTINE proc_sub_noarg ()

  END SUBROUTINE proc_sub_noarg

END MODULE testmod

PROGRAM main

  IMPLICIT NONE

  TYPE t

  CONTAINS

    PROCEDURE, NOPASS :: proc_no_module ! { dg-error "module procedure" }

  END TYPE t

CONTAINS

  SUBROUTINE proc_no_module ()

  END SUBROUTINE proc_no_module

END PROGRAM main

! { dg-final { cleanup-modules "othermod testmod" } }