gcc/testsuite/gfortran.dg/typebound_call_1.f03

   1 ! { dg-do run }
   2
   3 ! Type-bound procedures
   4 ! Check basic calls to NOPASS type-bound procedures.
   5
   6 MODULE m
   7   IMPLICIT NONE
   8
   9   TYPE add
  10   CONTAINS
  11     PROCEDURE, NOPASS :: func => func_add
  12     PROCEDURE, NOPASS :: sub => sub_add
  13     PROCEDURE, NOPASS :: echo => echo_add
  14   END TYPE add
  15
  16   TYPE mul
  17   CONTAINS
  18     PROCEDURE, NOPASS :: func => func_mul
  19     PROCEDURE, NOPASS :: sub => sub_mul
  20     PROCEDURE, NOPASS :: echo => echo_mul
  21   END TYPE mul
  22
  23 CONTAINS
  24
  25   INTEGER FUNCTION func_add (a, b)
  26     IMPLICIT NONE
  27     INTEGER :: a, b
  28     func_add = a + b
  29   END FUNCTION func_add
  30
  31   INTEGER FUNCTION func_mul (a, b)
  32     IMPLICIT NONE
  33     INTEGER :: a, b
  34     func_mul = a * b
  35   END FUNCTION func_mul
  36
  37   SUBROUTINE sub_add (a, b, c)
  38     IMPLICIT NONE
  39     INTEGER, INTENT(IN) :: a, b
  40     INTEGER, INTENT(OUT) :: c
  41     c = a + b
  42   END SUBROUTINE sub_add
  43
  44   SUBROUTINE sub_mul (a, b, c)
  45     IMPLICIT NONE
  46     INTEGER, INTENT(IN) :: a, b
  47     INTEGER, INTENT(OUT) :: c
  48     c = a * b
  49   END SUBROUTINE sub_mul
  50
  51   SUBROUTINE echo_add ()
  52     IMPLICIT NONE
  53     WRITE (*,*) "Hi from adder!"
  54   END SUBROUTINE echo_add
  55
  56   INTEGER FUNCTION echo_mul ()
  57     IMPLICIT NONE
  58     echo_mul = 5
  59     WRITE (*,*) "Hi from muler!"
  60   END FUNCTION echo_mul
  61
  62   ! Do the testing here, in the same module as the type is.
  63   SUBROUTINE test ()
  64     IMPLICIT NONE
  65
  66     TYPE(add) :: adder
  67     TYPE(mul) :: muler
  68
  69     INTEGER :: x
  70
  71     IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN
  72       CALL abort ()
  73     END IF
  74
  75     CALL adder%sub (2, 3, x)
  76     IF (x /= 5) THEN
  77       CALL abort ()
  78     END IF
  79
  80     CALL muler%sub (2, 3, x)
  81     IF (x /= 6) THEN
  82       CALL abort ()
  83     END IF
  84
  85     ! Check procedures without arguments.
  86     CALL adder%echo ()
  87     x = muler%echo ()
  88     CALL adder%echo
  89   END SUBROUTINE test
  90
  91 END MODULE m
  92
  93 PROGRAM main
  94   USE m, ONLY: test
  95   CALL test ()
  96 END PROGRAM main