flang/test/Semantics/resolve52.f90

   1 ! RUN: %S/test_errors.sh %s %t %flang_fc1
   2 ! REQUIRES: shell
   3 ! Tests for C760:
   4 ! The passed-object dummy argument shall be a scalar, nonpointer, nonallocatable
   5 ! dummy data object with the same declared type as the type being defined;
   6 ! all of its length type parameters shall be assumed; it shall be polymorphic
   7 ! (7.3.2.3) if and only if the type being defined is extensible (7.5.7).
   8 ! It shall not have the VALUE attribute.
   9 !
  10 ! C757 If the procedure pointer component has an implicit interface or has no
  11 ! arguments, NOPASS shall be specified.
  12 !
  13 ! C758 If PASS (arg-name) appears, the interface of the procedure pointer
  14 ! component shall have a dummy argument named arg-name.
  15
  16
  17 module m1
  18   type :: t
  19     procedure(real), pointer, nopass :: a
  20     !ERROR: Procedure component 'b' must have NOPASS attribute or explicit interface
  21     procedure(real), pointer :: b
  22   end type
  23 end
  24
  25 module m2
  26   type :: t
  27     !ERROR: Procedure component 'a' with no dummy arguments must have NOPASS attribute
  28     procedure(s1), pointer :: a
  29     !ERROR: Procedure component 'b' with no dummy arguments must have NOPASS attribute
  30     procedure(s1), pointer, pass :: b
  31   contains
  32     !ERROR: Procedure binding 'p1' with no dummy arguments must have NOPASS attribute
  33     procedure :: p1 => s1
  34     !ERROR: Procedure binding 'p2' with no dummy arguments must have NOPASS attribute
  35     procedure, pass :: p2 => s1
  36   end type
  37 contains
  38   subroutine s1()
  39   end
  40 end
  41
  42 module m3
  43   type :: t
  44     !ERROR: 'y' is not a dummy argument of procedure interface 's'
  45     procedure(s), pointer, pass(y) :: a
  46   contains
  47     !ERROR: 'z' is not a dummy argument of procedure interface 's'
  48     procedure, pass(z) :: p => s
  49   end type
  50 contains
  51   subroutine s(x)
  52     class(t) :: x
  53   end
  54 end
  55
  56 module m4
  57   type :: t
  58     !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not have the POINTER attribute
  59     procedure(s1), pointer :: a
  60     !ERROR: Passed-object dummy argument 'x' of procedure 'b' may not have the ALLOCATABLE attribute
  61     procedure(s2), pointer, pass(x) :: b
  62     !ERROR: Passed-object dummy argument 'f' of procedure 'c' must be a data object
  63     procedure(s3), pointer, pass :: c
  64     !ERROR: Passed-object dummy argument 'x' of procedure 'd' must be scalar
  65     procedure(s4), pointer, pass :: d
  66   end type
  67 contains
  68   subroutine s1(x)
  69     class(t), pointer :: x
  70   end
  71   subroutine s2(w, x)
  72     real :: x
  73     !ERROR: The type of 'x' has already been declared
  74     class(t), allocatable :: x
  75   end
  76   subroutine s3(f)
  77     interface
  78       real function f()
  79       end function
  80     end interface
  81   end
  82   subroutine s4(x)
  83     class(t) :: x(10)
  84   end
  85 end
  86
  87 module m5
  88   type :: t1
  89     sequence
  90     !ERROR: Passed-object dummy argument 'x' of procedure 'a' must be of type 't1' but is 'REAL(4)'
  91     procedure(s), pointer :: a
  92   end type
  93   type :: t2
  94   contains
  95     !ERROR: Passed-object dummy argument 'y' of procedure 's' must be of type 't2' but is 'TYPE(t1)'
  96     procedure, pass(y) :: s
  97   end type
  98 contains
  99   subroutine s(x, y)
 100     real :: x
 101     type(t1) :: y
 102   end
 103 end
 104
 105 module m6
 106   type :: t(k, l)
 107     integer, kind :: k
 108     integer, len :: l
 109     !ERROR: Passed-object dummy argument 'x' of procedure 'a' has non-assumed length parameter 'l'
 110     procedure(s1), pointer :: a
 111   end type
 112 contains
 113   subroutine s1(x)
 114     class(t(1, 2)) :: x
 115   end
 116 end
 117
 118 module m7
 119   type :: t
 120     sequence  ! t is not extensible
 121     !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not be polymorphic because 't' is not extensible
 122     procedure(s), pointer :: a
 123   end type
 124 contains
 125   subroutine s(x)
 126     !ERROR: Non-extensible derived type 't' may not be used with CLASS keyword
 127     class(t) :: x
 128   end
 129 end
 130
 131 module m8
 132   type :: t
 133   contains
 134     !ERROR: Passed-object dummy argument 'x' of procedure 's' must be polymorphic because 't' is extensible
 135     procedure :: s
 136   end type
 137 contains
 138   subroutine s(x)
 139     type(t) :: x  ! x is not polymorphic
 140   end
 141 end