gcc/testsuite/gfortran.dg/assumed_type_2.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-O0 -fdump-tree-original" }
   3 !
   4 ! PR fortran/48820
   5 !
   6 ! Test TYPE(*)
   7 !
   8
   9 module mod
  10   use iso_c_binding, only: c_loc, c_ptr, c_bool
  11   implicit none
  12   interface my_c_loc
  13     function my_c_loc1(x) bind(C)
  14       import c_ptr
  15       type(*) :: x
  16       type(c_ptr) :: my_c_loc1
  17     end function
  18     function my_c_loc2(x) bind(C)
  19       import c_ptr
  20       type(*) :: x(*)
  21       type(c_ptr) :: my_c_loc2
  22     end function
  23   end interface my_c_loc
  24 contains
  25   subroutine sub_scalar (arg1, presnt)
  26      type(*), target, optional :: arg1
  27      logical :: presnt
  28      type(c_ptr) :: cpt
  29      if (presnt .neqv. present (arg1)) STOP 1
  30      cpt = c_loc (arg1)
  31   end subroutine sub_scalar
  32
  33   subroutine sub_array_shape (arg2, lbounds, ubounds)
  34      type(*), target :: arg2(:,:)
  35      type(c_ptr) :: cpt
  36      integer :: lbounds(2), ubounds(2)
  37      if (any (lbound(arg2) /= lbounds)) STOP 2
  38      if (any (ubound(arg2) /= ubounds)) STOP 3
  39      if (any (shape(arg2) /= ubounds-lbounds+1)) STOP 4
  40      if (size(arg2) /= product (ubounds-lbounds+1)) STOP 5
  41      if (rank (arg2) /= 2) STOP 6
  42 !     if (.not. is_continuous (arg2)) STOP 7 !<< Not yet implemented
  43 !     cpt = c_loc (arg2) ! << FIXME: Valid since TS29113
  44      call sub_array_assumed (arg2)
  45   end subroutine sub_array_shape
  46
  47   subroutine sub_array_assumed (arg3)
  48      type(*), target :: arg3(*)
  49      type(c_ptr) :: cpt
  50      cpt = c_loc (arg3)
  51   end subroutine sub_array_assumed
  52 end module
  53
  54 use mod
  55 use iso_c_binding, only: c_int, c_null_ptr
  56 implicit none
  57 type t1
  58   integer :: a
  59 end type t1
  60 type :: t2
  61   sequence
  62   integer :: b
  63 end type t2
  64 type, bind(C) :: t3
  65   integer(c_int) :: c
  66 end type t3
  67
  68 integer            :: scalar_int
  69 real, allocatable  :: scalar_real_alloc
  70 character, pointer :: scalar_char_ptr
  71
  72 integer            :: array_int(3)
  73 real, allocatable  :: array_real_alloc(:,:)
  74 character, pointer :: array_char_ptr(:,:)
  75
  76 type(t1)              :: scalar_t1
  77 type(t2), allocatable :: scalar_t2_alloc
  78 type(t3), pointer     :: scalar_t3_ptr
  79
  80 type(t1)              :: array_t1(4)
  81 type(t2), allocatable :: array_t2_alloc(:,:)
  82 type(t3), pointer     :: array_t3_ptr(:,:)
  83
  84 class(t1), allocatable :: scalar_class_t1_alloc
  85 class(t1), pointer     :: scalar_class_t1_ptr
  86
  87 class(t1), allocatable :: array_class_t1_alloc(:,:)
  88 class(t1), pointer     :: array_class_t1_ptr(:,:)
  89
  90 scalar_char_ptr => null()
  91 scalar_t3_ptr => null()
  92
  93 call sub_scalar (presnt=.false.)
  94 call sub_scalar (scalar_real_alloc, .false.)
  95 call sub_scalar (scalar_char_ptr, .false.)
  96 call sub_scalar (null (), .false.)
  97 call sub_scalar (scalar_t2_alloc, .false.)
  98 call sub_scalar (scalar_t3_ptr, .false.)
  99
 100 allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr)
 101 allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc)
 102 allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2))
 103 allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2))
 104 allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4))
 105
 106 call sub_scalar (scalar_int, .true.)
 107 call sub_scalar (scalar_real_alloc, .true.)
 108 call sub_scalar (scalar_char_ptr, .true.)
 109 call sub_scalar (array_int(2), .true.)
 110 call sub_scalar (array_real_alloc(3,2), .true.)
 111 call sub_scalar (array_char_ptr(0,1), .true.)
 112 call sub_scalar (scalar_t1, .true.)
 113 call sub_scalar (scalar_t2_alloc, .true.)
 114 call sub_scalar (scalar_t3_ptr, .true.)
 115 call sub_scalar (array_t1(2), .true.)
 116 call sub_scalar (array_t2_alloc(3,2), .true.)
 117 call sub_scalar (array_t3_ptr(0,1), .true.)
 118 call sub_scalar (array_class_t1_alloc(2,1), .true.)
 119 call sub_scalar (array_class_t1_ptr(3,3), .true.)
 120
 121 call sub_array_assumed (array_int)
 122 call sub_array_assumed (array_real_alloc)
 123 call sub_array_assumed (array_char_ptr)
 124 call sub_array_assumed (array_t1)
 125 call sub_array_assumed (array_t2_alloc)
 126 call sub_array_assumed (array_t3_ptr)
 127 call sub_array_assumed (array_class_t1_alloc)
 128 call sub_array_assumed (array_class_t1_ptr)
 129
 130 call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc))
 131 call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr))
 132 call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc))
 133 call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr))
 134 call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc))
 135 call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr))
 136
 137 deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr)
 138 deallocate (array_class_t1_ptr, array_t3_ptr)
 139
 140 end
 141
 142 ! { dg-final { scan-tree-dump-times "sub_scalar .0B,"  2 "original" } }
 143 ! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } }
 144 ! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } }
 145 ! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } }
 146 ! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } }
 147
 148 ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } }
 149 ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
 150 ! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } }
 151 ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
 152
 153 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
 154 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } }
 155 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
 156 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } }
 157 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
 158 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
 159
 160 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 4 "original" } }
 161 ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } }
 162 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } }
 163 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } }
 164 ! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } }
 165 ! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } }
 166 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } }
 167 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } }
 168 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } }
 169 ! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 0 "original" } }
 170
 171 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } }
 172 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } }
 173 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t2_alloc," 1 "original" } }
 174 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t3_ptr," 1 "original" } }
 175 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_alloc._data," 1 "original" } }
 176 ! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_ptr._data," 1 "original" } }
 177