flang/test/Semantics/bindings01.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! Confirm enforcement of constraints and restrictions in 7.5.7.3
   3 ! and C733, C734 and C779, C780, C782, C783, C784, and C785.
   4
   5 module m
   6   !ERROR: An ABSTRACT derived type must be extensible
   7   type, abstract, bind(c) :: badAbstract1
   8   end type
   9   !ERROR: An ABSTRACT derived type must be extensible
  10   type, abstract :: badAbstract2
  11     sequence
  12     real :: badAbstract2Field
  13   end type
  14   type, abstract :: abstract
  15    contains
  16     !ERROR: DEFERRED is required when an interface-name is provided
  17     procedure(s1), pass :: ab1
  18     !ERROR: Type-bound procedure 'ab3' may not be both DEFERRED and NON_OVERRIDABLE
  19     procedure(s1), deferred, non_overridable :: ab3
  20     !ERROR: DEFERRED is only allowed when an interface-name is provided
  21     procedure, deferred, non_overridable :: ab4 => s1
  22   end type
  23   type :: nonoverride
  24    contains
  25     procedure, non_overridable, nopass :: no1 => s1
  26   end type
  27   type, extends(nonoverride) :: nonoverride2
  28   end type
  29   type, extends(nonoverride2) :: nonoverride3
  30    contains
  31     !ERROR: Override of NON_OVERRIDABLE 'no1' is not permitted
  32     procedure, nopass :: no1 => s1
  33   end type
  34   type, abstract :: missing
  35    contains
  36     procedure(s4), deferred :: am1
  37   end type
  38   !ERROR: Non-ABSTRACT extension of ABSTRACT derived type 'missing' lacks a binding for DEFERRED procedure 'am1'
  39   type, extends(missing) :: concrete
  40   end type
  41   type, extends(missing) :: intermediate
  42    contains
  43     procedure :: am1 => s7
  44   end type
  45   type, extends(intermediate) :: concrete2  ! ensure no false missing binding error
  46   end type
  47   type, bind(c) :: inextensible1
  48   end type
  49   !ERROR: The parent type is not extensible
  50   type, extends(inextensible1) :: badExtends1
  51   end type
  52   type :: inextensible2
  53     sequence
  54     real :: inextensible2Field
  55   end type
  56   !ERROR: The parent type is not extensible
  57   type, extends(inextensible2) :: badExtends2
  58   end type
  59   !ERROR: Derived type 'real' not found
  60   type, extends(real) :: badExtends3
  61   end type
  62   type :: base
  63     real :: component
  64    contains
  65     !ERROR: Procedure bound to non-ABSTRACT derived type 'base' may not be DEFERRED
  66     procedure(s2), deferred :: bb1
  67     !ERROR: DEFERRED is only allowed when an interface-name is provided
  68     procedure, deferred :: bb2 => s2
  69   end type
  70   type, extends(base) :: extension
  71    contains
  72      !ERROR: A type-bound procedure binding may not have the same name as a parent component
  73      procedure :: component => s3
  74   end type
  75   type :: nopassBase
  76    contains
  77     procedure, nopass :: tbp => s1
  78   end type
  79   type, extends(nopassBase) :: passExtends
  80    contains
  81     !ERROR: A passed-argument type-bound procedure may not override a NOPASS procedure
  82     procedure :: tbp => s5
  83   end type
  84   type :: passBase
  85    contains
  86     procedure :: tbp => s6
  87   end type
  88   type, extends(passBase) :: nopassExtends
  89    contains
  90     !ERROR: A NOPASS type-bound procedure may not override a passed-argument procedure
  91     procedure, nopass :: tbp => s1
  92   end type
  93  contains
  94   subroutine s1(x)
  95     class(abstract), intent(in) :: x
  96   end subroutine s1
  97   subroutine s2(x)
  98     class(base), intent(in) :: x
  99   end subroutine s2
 100   subroutine s3(x)
 101     class(extension), intent(in) :: x
 102   end subroutine s3
 103   subroutine s4(x)
 104     class(missing), intent(in) :: x
 105   end subroutine s4
 106   subroutine s5(x)
 107     class(passExtends), intent(in) :: x
 108   end subroutine s5
 109   subroutine s6(x)
 110     class(passBase), intent(in) :: x
 111   end subroutine s6
 112   subroutine s7(x)
 113     class(intermediate), intent(in) :: x
 114   end subroutine s7
 115 end module
 116
 117 module m1
 118   implicit none
 119   interface g
 120     module procedure mp
 121   end interface g
 122
 123   type t
 124   contains
 125     !ERROR: The binding of 'tbp' ('g') must be either an accessible module procedure or an external procedure with an explicit interface
 126     procedure,pass(x) :: tbp => g
 127   end type t
 128
 129 contains
 130   subroutine mp(x)
 131     class(t),intent(in) :: x
 132   end subroutine
 133 end module m1
 134
 135 module m2
 136   type parent
 137     real realField
 138   contains
 139     !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
 140     procedure proc
 141   end type parent
 142   type,extends(parent) :: child
 143   contains
 144     !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
 145     procedure proc
 146   end type child
 147 contains
 148   subroutine proc
 149   end subroutine
 150 end module m2
 151
 152 module m3
 153   type t
 154   contains
 155     procedure b
 156   end type
 157 contains
 158   !ERROR: Cannot use an alternate return as the passed-object dummy argument
 159   subroutine b(*)
 160     return 1
 161   end subroutine
 162 end module m3
 163
 164 module m4
 165   type t
 166   contains
 167     procedure b
 168   end type
 169 contains
 170   ! Check to see that alternate returns work with default PASS arguments
 171   subroutine b(this, *)
 172     class(t) :: this
 173     return 1
 174   end subroutine
 175 end module m4
 176
 177 module m5
 178   type t
 179   contains
 180     !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be of type 't' but is 'INTEGER(4)'
 181     procedure, pass(passArg) ::  b
 182   end type
 183 contains
 184   subroutine b(*, passArg)
 185     integer :: passArg
 186     return 1
 187   end subroutine
 188 end module m5
 189
 190 module m6
 191   type t
 192   contains
 193     !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be polymorphic because 't' is extensible
 194     procedure, pass(passArg) ::  b
 195   end type
 196 contains
 197   subroutine b(*, passArg)
 198     type(t) :: passArg
 199     return 1
 200   end subroutine
 201 end module m6
 202
 203 module m7
 204   type t
 205   contains
 206   ! Check to see that alternate returns work with PASS arguments
 207     procedure, pass(passArg) ::  b
 208   end type
 209 contains
 210   subroutine b(*, passArg)
 211     class(t) :: passArg
 212     return 1
 213   end subroutine
 214 end module m7
 215
 216 program test
 217   use m1
 218   type,extends(t) :: t2
 219   end type
 220   type(t2) a
 221   call a%tbp
 222 end program