flang/test/Semantics/selecttype03.f90

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