Subversion Repositories openrisc_2011-10-31

! { dg-do run }

! Type-bound procedures
! Check they can actually be called and run correctly.
! This also checks for correct module save/restore.

! FIXME: Check that calls to inherited bindings work once CLASS allows that.

MODULE m
  IMPLICIT NONE

  TYPE mynum
    REAL :: num_real
    INTEGER :: num_int
  CONTAINS
    PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE.
    PROCEDURE, PASS :: add_int
    PROCEDURE, PASS :: add_real
    PROCEDURE, PASS :: assign_int
    PROCEDURE, PASS :: assign_real
    PROCEDURE, PASS(from) :: assign_to_int
    PROCEDURE, PASS(from) :: assign_to_real
    PROCEDURE, PASS :: get_all

    GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real
    GENERIC :: OPERATOR(.GET.) => get_all
    GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, &
                                assign_to_int, assign_to_real
  END TYPE mynum

CONTAINS

  TYPE(mynum) FUNCTION add_mynum (a, b)
    CLASS(mynum), INTENT(IN) :: a, b
    add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int)
  END FUNCTION add_mynum

  TYPE(mynum) FUNCTION add_int (a, b)
    CLASS(mynum), INTENT(IN) :: a
    INTEGER, INTENT(IN) :: b
    add_int = mynum (a%num_real, a%num_int + b)
  END FUNCTION add_int

  TYPE(mynum) FUNCTION add_real (a, b)
    CLASS(mynum), INTENT(IN) :: a
    REAL, INTENT(IN) :: b
    add_real = mynum (a%num_real + b, a%num_int)
  END FUNCTION add_real

  REAL FUNCTION get_all (me)
    CLASS(mynum), INTENT(IN) :: me
    get_all = me%num_real + me%num_int
  END FUNCTION get_all

  SUBROUTINE assign_real (dest, from)
    CLASS(mynum), INTENT(INOUT) :: dest
    REAL, INTENT(IN) :: from
    dest%num_real = from
  END SUBROUTINE assign_real

  SUBROUTINE assign_int (dest, from)
    CLASS(mynum), INTENT(INOUT) :: dest
    INTEGER, INTENT(IN) :: from
    dest%num_int = from
  END SUBROUTINE assign_int

  SUBROUTINE assign_to_real (dest, from)
    REAL, INTENT(OUT) :: dest
    CLASS(mynum), INTENT(IN) :: from
    dest = from%num_real
  END SUBROUTINE assign_to_real

  SUBROUTINE assign_to_int (dest, from)
    INTEGER, INTENT(OUT) :: dest
    CLASS(mynum), INTENT(IN) :: from
    dest = from%num_int
  END SUBROUTINE assign_to_int

  ! Test it works basically within the module.
  SUBROUTINE check_in_module ()
    IMPLICIT NONE
    TYPE(mynum) :: num

    num = mynum (1.0, 2)
    num = num + 7
    IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort ()
  END SUBROUTINE check_in_module

END MODULE m

! Here we see it also works for use-associated operators loaded from a module.
PROGRAM main
  USE m, ONLY: mynum, check_in_module
  IMPLICIT NONE

  TYPE(mynum) :: num1, num2, num3
  REAL :: real_var
  INTEGER :: int_var

  CALL check_in_module ()

  num1 = mynum (1.0, 2)
  num2 = mynum (2.0, 3)

  num3 = num1 + num2
  IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort ()

  num3 = num1 + 5
  IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort ()

  num3 = num1 + (-100.5)
  IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort ()

  num3 = 42
  num3 = -1.2
  IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort ()

  real_var = num3
  int_var = num3
  IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort ()

  IF (.GET. num1 /= 3.0) CALL abort ()
END PROGRAM main

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