flang/test/Semantics/bindings01.f90

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