gcc/testsuite/gfortran.dg/typebound_call_2.f03

   1 ! { dg-do run }
   2
   3 ! Type-bound procedures
   4 ! Check calls with passed-objects.
   5
   6 MODULE m
   7   IMPLICIT NONE
   8
   9   TYPE add
  10     INTEGER :: wrong
  11     INTEGER :: val
  12   CONTAINS
  13     PROCEDURE, PASS :: func => func_add
  14     PROCEDURE, PASS(me) :: sub => sub_add
  15   END TYPE add
  16
  17   TYPE trueOrFalse
  18     LOGICAL :: val
  19   CONTAINS
  20     PROCEDURE, PASS :: swap
  21   END TYPE trueOrFalse
  22
  23 CONTAINS
  24
  25   INTEGER FUNCTION func_add (me, x)
  26     IMPLICIT NONE
  27     CLASS(add) :: me
  28     INTEGER :: x
  29     func_add = me%val + x
  30   END FUNCTION func_add
  31
  32   SUBROUTINE sub_add (res, me, x)
  33     IMPLICIT NONE
  34     INTEGER, INTENT(OUT) :: res
  35     CLASS(add), INTENT(IN) :: me
  36     INTEGER, INTENT(IN) :: x
  37     res = me%val + x
  38   END SUBROUTINE sub_add
  39
  40   SUBROUTINE swap (me1, me2)
  41     IMPLICIT NONE
  42     CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2
  43
  44     IF (.NOT. me1%val .OR. me2%val) THEN
  45       STOP 1
  46     END IF
  47
  48     me1%val = .FALSE.
  49     me2%val = .TRUE.
  50   END SUBROUTINE swap
  51
  52   ! Do the testing here, in the same module as the type is.
  53   SUBROUTINE test ()
  54     IMPLICIT NONE
  55
  56     TYPE(add) :: adder
  57     TYPE(trueOrFalse) :: t, f
  58
  59     INTEGER :: x
  60
  61     adder%wrong = 0
  62     adder%val = 42
  63     IF (adder%func (8) /= 50) THEN
  64       STOP 2
  65     END IF
  66
  67     CALL adder%sub (x, 8)
  68     IF (x /=  50) THEN
  69       STOP 3
  70     END IF
  71
  72     t%val = .TRUE.
  73     f%val = .FALSE.
  74
  75     CALL t%swap (f)
  76     CALL f%swap (t)
  77
  78     IF (.NOT. t%val .OR. f%val) THEN
  79       STOP 4
  80     END IF
  81   END SUBROUTINE test
  82
  83 END MODULE m
  84
  85 PROGRAM main
  86   USE m, ONLY: test
  87   CALL test ()
  88 END PROGRAM main