gcc/testsuite/gfortran.dg/assumed_type_2a.f90

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