gcc/testsuite/gfortran.dg/typebound_call_2.f03

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