gcc/testsuite/gfortran.dg/typebound_operator_3.f03

   1 ! { dg-do run }
   2
   3 ! Type-bound procedures
   4 ! Check they can actually be called and run correctly.
   5 ! This also checks for correct module save/restore.
   6
   7 ! FIXME: Check that calls to inherited bindings work once CLASS allows that.
   8
   9 MODULE m
  10   IMPLICIT NONE
  11
  12   TYPE mynum
  13     REAL :: num_real
  14     INTEGER :: num_int
  15   CONTAINS
  16     PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE.
  17     PROCEDURE, PASS :: add_int
  18     PROCEDURE, PASS :: add_real
  19     PROCEDURE, PASS :: assign_int
  20     PROCEDURE, PASS :: assign_real
  21     PROCEDURE, PASS(from) :: assign_to_int
  22     PROCEDURE, PASS(from) :: assign_to_real
  23     PROCEDURE, PASS :: get_all
  24
  25     GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real
  26     GENERIC :: OPERATOR(.GET.) => get_all
  27     GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, &
  28                                 assign_to_int, assign_to_real
  29   END TYPE mynum
  30
  31 CONTAINS
  32
  33   TYPE(mynum) FUNCTION add_mynum (a, b)
  34     CLASS(mynum), INTENT(IN) :: a, b
  35     add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int)
  36   END FUNCTION add_mynum
  37
  38   TYPE(mynum) FUNCTION add_int (a, b)
  39     CLASS(mynum), INTENT(IN) :: a
  40     INTEGER, INTENT(IN) :: b
  41     add_int = mynum (a%num_real, a%num_int + b)
  42   END FUNCTION add_int
  43
  44   TYPE(mynum) FUNCTION add_real (a, b)
  45     CLASS(mynum), INTENT(IN) :: a
  46     REAL, INTENT(IN) :: b
  47     add_real = mynum (a%num_real + b, a%num_int)
  48   END FUNCTION add_real
  49
  50   REAL FUNCTION get_all (me)
  51     CLASS(mynum), INTENT(IN) :: me
  52     get_all = me%num_real + me%num_int
  53   END FUNCTION get_all
  54
  55   SUBROUTINE assign_real (dest, from)
  56     CLASS(mynum), INTENT(INOUT) :: dest
  57     REAL, INTENT(IN) :: from
  58     dest%num_real = from
  59   END SUBROUTINE assign_real
  60
  61   SUBROUTINE assign_int (dest, from)
  62     CLASS(mynum), INTENT(INOUT) :: dest
  63     INTEGER, INTENT(IN) :: from
  64     dest%num_int = from
  65   END SUBROUTINE assign_int
  66
  67   SUBROUTINE assign_to_real (dest, from)
  68     REAL, INTENT(OUT) :: dest
  69     CLASS(mynum), INTENT(IN) :: from
  70     dest = from%num_real
  71   END SUBROUTINE assign_to_real
  72
  73   SUBROUTINE assign_to_int (dest, from)
  74     INTEGER, INTENT(OUT) :: dest
  75     CLASS(mynum), INTENT(IN) :: from
  76     dest = from%num_int
  77   END SUBROUTINE assign_to_int
  78
  79   ! Test it works basically within the module.
  80   SUBROUTINE check_in_module ()
  81     IMPLICIT NONE
  82     TYPE(mynum) :: num
  83
  84     num = mynum (1.0, 2)
  85     num = num + 7
  86     IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort ()
  87   END SUBROUTINE check_in_module
  88
  89 END MODULE m
  90
  91 ! Here we see it also works for use-associated operators loaded from a module.
  92 PROGRAM main
  93   USE m, ONLY: mynum, check_in_module
  94   IMPLICIT NONE
  95
  96   TYPE(mynum) :: num1, num2, num3
  97   REAL :: real_var
  98   INTEGER :: int_var
  99
 100   CALL check_in_module ()
 101
 102   num1 = mynum (1.0, 2)
 103   num2 = mynum (2.0, 3)
 104
 105   num3 = num1 + num2
 106   IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort ()
 107
 108   num3 = num1 + 5
 109   IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort ()
 110
 111   num3 = num1 + (-100.5)
 112   IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort ()
 113
 114   num3 = 42
 115   num3 = -1.2
 116   IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort ()
 117
 118   real_var = num3
 119   int_var = num3
 120   IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort ()
 121
 122   IF (.GET. num1 /= 3.0) CALL abort ()
 123 END PROGRAM main
 124
 125 ! { dg-final { cleanup-modules "m" } }