Subversion Repositories openrisc

! { dg-do run }

! Type-bound procedures

! Check basic calls to NOPASS type-bound procedures.

MODULE m

  IMPLICIT NONE

  TYPE add

  CONTAINS

    PROCEDURE, NOPASS :: func => func_add

    PROCEDURE, NOPASS :: sub => sub_add

    PROCEDURE, NOPASS :: echo => echo_add

  END TYPE add

  TYPE mul

  CONTAINS

    PROCEDURE, NOPASS :: func => func_mul

    PROCEDURE, NOPASS :: sub => sub_mul

    PROCEDURE, NOPASS :: echo => echo_mul

  END TYPE mul

CONTAINS

  INTEGER FUNCTION func_add (a, b)

    IMPLICIT NONE

    INTEGER :: a, b

    func_add = a + b

  END FUNCTION func_add

  INTEGER FUNCTION func_mul (a, b)

    IMPLICIT NONE

    INTEGER :: a, b

    func_mul = a * b

  END FUNCTION func_mul

  SUBROUTINE sub_add (a, b, c)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: a, b

    INTEGER, INTENT(OUT) :: c

    c = a + b

  END SUBROUTINE sub_add

  SUBROUTINE sub_mul (a, b, c)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: a, b

    INTEGER, INTENT(OUT) :: c

    c = a * b

  END SUBROUTINE sub_mul

  SUBROUTINE echo_add ()

    IMPLICIT NONE

    WRITE (*,*) "Hi from adder!"

  END SUBROUTINE echo_add

  INTEGER FUNCTION echo_mul ()

    IMPLICIT NONE

    echo_mul = 5

    WRITE (*,*) "Hi from muler!"

  END FUNCTION echo_mul

  ! Do the testing here, in the same module as the type is.

  SUBROUTINE test ()

    IMPLICIT NONE

    TYPE(add) :: adder

    TYPE(mul) :: muler

    INTEGER :: x

    IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN

      CALL abort ()

    END IF

    CALL adder%sub (2, 3, x)

    IF (x /= 5) THEN

      CALL abort ()

    END IF

    CALL muler%sub (2, 3, x)

    IF (x /= 6) THEN

      CALL abort ()

    END IF

    ! Check procedures without arguments.

    CALL adder%echo ()

    x = muler%echo ()

    CALL adder%echo

  END SUBROUTINE test

END MODULE m

PROGRAM main

  USE m, ONLY: test

  CALL test ()

END PROGRAM main

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