gcc/testsuite/gfortran.dg/typebound_proc_6.f03

   1 ! { dg-do compile }
   2
   3 ! Type-bound procedures
   4 ! Test for the check if overriding methods "match" the overridden ones by their
   5 ! characteristics.
   6
   7 MODULE testmod
   8   IMPLICIT NONE
   9
  10   TYPE supert
  11   CONTAINS
  12
  13     ! For checking the PURE/ELEMENTAL matching.
  14     PROCEDURE, NOPASS :: pure1 => proc_pure
  15     PROCEDURE, NOPASS :: pure2 => proc_pure
  16     PROCEDURE, NOPASS :: nonpure => proc_sub
  17     PROCEDURE, NOPASS :: elemental1 => proc_elemental
  18     PROCEDURE, NOPASS :: elemental2 => proc_elemental
  19     PROCEDURE, NOPASS :: nonelem1 => proc_nonelem
  20     PROCEDURE, NOPASS :: nonelem2 => proc_nonelem
  21
  22     ! Same number of arguments!
  23     PROCEDURE, NOPASS :: three_args_1 => proc_threearg
  24     PROCEDURE, NOPASS :: three_args_2 => proc_threearg
  25
  26     ! For SUBROUTINE/FUNCTION/result checking.
  27     PROCEDURE, NOPASS :: subroutine1 => proc_sub
  28     PROCEDURE, NOPASS :: subroutine2 => proc_sub
  29     PROCEDURE, NOPASS :: intfunction1 => proc_intfunc
  30     PROCEDURE, NOPASS :: intfunction2 => proc_intfunc
  31     PROCEDURE, NOPASS :: intfunction3 => proc_intfunc
  32
  33     ! For access-based checks.
  34     PROCEDURE, NOPASS, PRIVATE :: priv => proc_sub
  35     PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub
  36     PROCEDURE, NOPASS, PUBLIC :: publ2 => proc_sub
  37
  38     ! For passed-object dummy argument checks.
  39     PROCEDURE, NOPASS :: nopass1 => proc_stme1
  40     PROCEDURE, NOPASS :: nopass2 => proc_stme1
  41     PROCEDURE, PASS :: pass1 => proc_stme1
  42     PROCEDURE, PASS(me) :: pass2 => proc_stme1
  43     PROCEDURE, PASS(me1) :: pass3 => proc_stmeme
  44
  45     ! For corresponding dummy arguments.
  46     PROCEDURE, PASS :: corresp1 => proc_stmeint
  47     PROCEDURE, PASS :: corresp2 => proc_stmeint
  48     PROCEDURE, PASS :: corresp3 => proc_stmeint
  49
  50   END TYPE supert
  51
  52   ! Checking for NON_OVERRIDABLE is in typebound_proc_5.f03.
  53
  54   TYPE, EXTENDS(supert) :: t
  55   CONTAINS
  56
  57     ! For checking the PURE/ELEMENTAL matching.
  58     PROCEDURE, NOPASS :: pure1 => proc_pure ! Ok, both pure.
  59     PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" }
  60     PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure.
  61     PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental.
  62     PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" }
  63     PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental.
  64     PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" }
  65
  66     ! Same number of arguments!
  67     PROCEDURE, NOPASS :: three_args_1 => proc_threearg ! Ok.
  68     PROCEDURE, NOPASS :: three_args_2 => proc_twoarg ! { dg-error "same number of formal arguments" }
  69
  70     ! For SUBROUTINE/FUNCTION/result checking.
  71     PROCEDURE, NOPASS :: subroutine1 => proc_sub ! Ok, both subroutines.
  72     PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" }
  73     PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions.
  74     PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" }
  75     PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" }
  76
  77     ! For access-based checks.
  78     PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.
  79     PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub ! Ok, both PUBLIC.
  80     PROCEDURE, NOPASS, PRIVATE :: publ2 => proc_sub ! { dg-error "must not be PRIVATE" }
  81
  82     ! For passed-object dummy argument checks.
  83     PROCEDURE, NOPASS :: nopass1 => proc_stme1 ! Ok, both NOPASS.
  84     PROCEDURE, PASS :: nopass2 => proc_tme1 ! { dg-error "must also be NOPASS" }
  85     PROCEDURE, PASS :: pass1 => proc_tme1 ! Ok.
  86     PROCEDURE, NOPASS :: pass2 => proc_stme1 ! { dg-error "must also be PASS" }
  87     PROCEDURE, PASS(me2) :: pass3 => proc_tmeme ! { dg-error "same position" }
  88
  89     ! For corresponding dummy arguments.
  90     PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok.
  91     PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" }
  92     PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" }
  93
  94   END TYPE t
  95
  96 CONTAINS
  97
  98   PURE SUBROUTINE proc_pure ()
  99   END SUBROUTINE proc_pure
 100
 101   ELEMENTAL SUBROUTINE proc_elemental (arg)
 102     IMPLICIT NONE
 103     INTEGER, INTENT(INOUT) :: arg
 104   END SUBROUTINE proc_elemental
 105
 106   SUBROUTINE proc_nonelem (arg)
 107     IMPLICIT NONE
 108     INTEGER, INTENT(INOUT) :: arg
 109   END SUBROUTINE proc_nonelem
 110
 111   SUBROUTINE proc_threearg (a, b, c)
 112     IMPLICIT NONE
 113     INTEGER :: a, b, c
 114   END SUBROUTINE proc_threearg
 115
 116   SUBROUTINE proc_twoarg (a, b)
 117     IMPLICIT NONE
 118     INTEGER :: a, b
 119   END SUBROUTINE proc_twoarg
 120
 121   SUBROUTINE proc_sub ()
 122   END SUBROUTINE proc_sub
 123
 124   INTEGER FUNCTION proc_intfunc ()
 125     proc_intfunc = 42
 126   END FUNCTION proc_intfunc
 127
 128   REAL FUNCTION proc_realfunc ()
 129     proc_realfunc = 42.0
 130   END FUNCTION proc_realfunc
 131
 132   SUBROUTINE proc_stme1 (me, a)
 133     IMPLICIT NONE
 134     TYPE(supert) :: me
 135     INTEGER :: a
 136   END SUBROUTINE proc_stme1
 137
 138   SUBROUTINE proc_tme1 (me, a)
 139     IMPLICIT NONE
 140     TYPE(t) :: me
 141     INTEGER :: a
 142   END SUBROUTINE proc_tme1
 143
 144   SUBROUTINE proc_stmeme (me1, me2)
 145     IMPLICIT NONE
 146     TYPE(supert) :: me1, me2
 147   END SUBROUTINE proc_stmeme
 148
 149   SUBROUTINE proc_tmeme (me1, me2)
 150     IMPLICIT NONE
 151     TYPE(t) :: me1, me2
 152   END SUBROUTINE proc_tmeme
 153
 154   SUBROUTINE proc_stmeint (me, a)
 155     IMPLICIT NONE
 156     TYPE(supert) :: me
 157     INTEGER :: a
 158   END SUBROUTINE proc_stmeint
 159
 160   SUBROUTINE proc_tmeint (me, a)
 161     IMPLICIT NONE
 162     TYPE(t) :: me
 163     INTEGER :: a
 164   END SUBROUTINE proc_tmeint
 165
 166   SUBROUTINE proc_tmeintx (me, x)
 167     IMPLICIT NONE
 168     TYPE(t) :: me
 169     INTEGER :: x
 170   END SUBROUTINE proc_tmeintx
 171
 172   SUBROUTINE proc_tmereal (me, a)
 173     IMPLICIT NONE
 174     TYPE(t) :: me
 175     REAL :: a
 176   END SUBROUTINE proc_tmereal
 177
 178 END MODULE testmod
 179
 180 ! { dg-final { cleanup-modules "testmod" } }
 181 ! FIXME: Remove not-yet-implemented error when implemented.
 182 ! { dg-excess-errors "not yet implemented" }