1! { dg-do run } 2 3! Type-bound procedures 4! Check calls with passed-objects. 5 6MODULE 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 23CONTAINS 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 CALL abort () 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 CALL abort () 65 END IF 66 67 CALL adder%sub (x, 8) 68 IF (x /= 50) THEN 69 CALL abort () 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 CALL abort () 80 END IF 81 END SUBROUTINE test 82 83END MODULE m 84 85PROGRAM main 86 USE m, ONLY: test 87 CALL test () 88END PROGRAM main 89