flang/test/Semantics/selecttype03.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! Test various conditions in C1158.
   3 implicit none
   4
   5 type :: t1
   6   integer :: i
   7 end type
   8
   9 type, extends(t1) :: t2
  10 end type
  11
  12 type(t1),target :: x1
  13 type(t2),target :: x2
  14
  15 class(*), pointer :: ptr
  16 class(t1), pointer :: p_or_c
  17 !vector subscript related
  18 class(t1),DIMENSION(:,:),allocatable::array1
  19 class(t2),DIMENSION(:,:),allocatable::array2
  20 integer, dimension(2) :: V
  21 V = (/ 1,2 /)
  22 allocate(array1(3,3))
  23 allocate(array2(3,3))
  24
  25 ! A) associate with function, i.e (other than variables)
  26 select type ( y => fun(1) )
  27   type is (t1)
  28     print *, rank(y%i)
  29 end select
  30
  31 select type ( y => fun(1) )
  32   type is (t1)
  33     y%i = 1 !VDC
  34   type is (t2)
  35     call sub_with_in_and_inout_param(y,y) !VDC
  36 end select
  37
  38 select type ( y => (fun(1)) )
  39   type is (t1)
  40     !ERROR: Left-hand side of assignment is not definable
  41     !BECAUSE: 'y' is construct associated with an expression
  42     y%i = 1 !VDC
  43   type is (t2)
  44     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable
  45     !BECAUSE: 'y' is construct associated with an expression
  46     call sub_with_in_and_inout_param(y,y) !VDC
  47 end select
  48
  49 ! B) associated with a variable:
  50 p_or_c => x1
  51 select type ( a => p_or_c )
  52   type is (t1)
  53     a%i = 10
  54 end select
  55
  56 select type ( a => p_or_c )
  57   type is (t1)
  58 end select
  59
  60 !C)Associate with  with vector subscript
  61 select type (b => array1(V,2))
  62   type is (t1)
  63     !ERROR: Left-hand side of assignment is not definable
  64     !BECAUSE: Construct association 'b' has a vector subscript
  65     b%i  = 1 !VDC
  66   type is (t2)
  67     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable
  68     !BECAUSE: Variable 'b' has a vector subscript
  69     call sub_with_in_and_inout_param_vector(b,b) !VDC
  70 end select
  71 select type(b =>  foo(1) )
  72   type is (t1)
  73     !ERROR: Left-hand side of assignment is not definable
  74     !BECAUSE: 'b' is construct associated with an expression
  75     b%i = 1 !VDC
  76   type is (t2)
  77     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable
  78     !BECAUSE: 'b' is construct associated with an expression
  79     call sub_with_in_and_inout_param_vector(b,b) !VDC
  80 end select
  81
  82 !D) Have no association and should be ok.
  83 !1. points to function
  84 ptr => fun(1)
  85 select type ( ptr )
  86 type is (t1)
  87   ptr%i = 1
  88 end select
  89
  90 !2. points to variable
  91 ptr=>x1
  92 select type (ptr)
  93   type is (t1)
  94     ptr%i = 10
  95 end select
  96
  97 contains
  98
  99   function fun(i)
 100     class(t1),pointer :: fun
 101     integer :: i
 102     if (i>0) then
 103       fun => x1
 104     else if (i<0) then
 105       fun => x2
 106     else
 107       fun => NULL()
 108     end if
 109   end function
 110
 111   function foo(i)
 112     integer :: i
 113     class(t1),DIMENSION(:),allocatable :: foo
 114     integer, dimension(2) :: U
 115     U = (/ 1,2 /)
 116     if (i>0) then
 117       foo = array1(2,U)
 118     else if (i<0) then
 119       foo = array2(2,U) ! ok: t2 extends t1
 120     end if
 121   end function
 122
 123   function foo2()
 124     class(t2),DIMENSION(:),allocatable :: foo2
 125     !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types CLASS(t2) and CLASS(t1)
 126     foo2 = array1(2,:)
 127   end function
 128
 129   subroutine sub_with_in_and_inout_param(y, z)
 130     type(t2), INTENT(IN) :: y
 131     class(t2), INTENT(INOUT) :: z
 132     z%i = 10
 133   end subroutine
 134
 135   subroutine sub_with_in_and_inout_param_vector(y, z)
 136     type(t2),DIMENSION(:), INTENT(IN) :: y
 137     class(t2),DIMENSION(:), INTENT(INOUT) :: z
 138     z%i = 10
 139   end subroutine
 140
 141 end