gcc/testsuite/gfortran.dg/interface_49.f90

   1 ! { dg-do run }
   2 ! PR fortran/61615 - resolve correct generic with TYPE(C_PTR) arguments
   3 ! PR fortran/99982 - dto. with C_PTR and C_FUNPTR
   4 ! Contributed by Jacob Abel and Scot Breitenfeld
   5
   6 MODULE foo
   7   USE iso_c_binding, only : c_ptr, c_funptr
   8   IMPLICIT NONE
   9   integer      :: rank = -99
  10   character(8) :: ctyp = ""
  11   INTERFACE bar
  12     MODULE PROCEDURE bar_s
  13     MODULE PROCEDURE bar_a1d
  14     MODULE PROCEDURE bar_a2d
  15     MODULE PROCEDURE bar_fp
  16     MODULE PROCEDURE bar_fp1
  17     MODULE PROCEDURE bar_fpx
  18   END INTERFACE bar
  19 CONTAINS
  20   SUBROUTINE bar_s(a)
  21     TYPE(c_ptr) :: a
  22     WRITE (0, *) 'in bar_s'
  23     rank = 0
  24     ctyp = "c_ptr"
  25   END SUBROUTINE bar_s
  26
  27   SUBROUTINE bar_a1d(a)
  28     TYPE(c_ptr) :: a(:)
  29     WRITE (0, *) 'in bar_a1d'
  30     rank = 1
  31     ctyp = "c_ptr"
  32   END SUBROUTINE bar_a1d
  33
  34   SUBROUTINE bar_a2d(a)
  35     TYPE(c_ptr) :: a(:,:)
  36     WRITE (0, *) 'in bar_a2d'
  37     rank = 2
  38     ctyp = "c_ptr"
  39   END SUBROUTINE bar_a2d
  40
  41   SUBROUTINE bar_fp(a)
  42     TYPE(c_funptr) :: a
  43     WRITE (0, *) 'in bar_fp'
  44     rank = 0
  45     ctyp = "c_funptr"
  46   END SUBROUTINE bar_fp
  47
  48   SUBROUTINE bar_fp1(a)
  49     TYPE(c_funptr) :: a(:)
  50     WRITE (0, *) 'in bar_fp1'
  51     rank = 1
  52     ctyp = "c_funptr"
  53   END SUBROUTINE bar_fp1
  54
  55   SUBROUTINE bar_fpx(a, b)
  56     TYPE(c_funptr) :: a(..)
  57     TYPE(c_ptr)    :: b
  58     WRITE (0, *) 'in bar_fpx'
  59     rank = -1
  60     ctyp = "c_funptr"
  61   END SUBROUTINE bar_fpx
  62 END MODULE foo
  63
  64 PROGRAM cptr_array_vs_scalar_arg
  65   USE foo
  66   USE iso_c_binding, only : c_ptr, c_loc, c_funptr
  67   IMPLICIT NONE
  68   INTEGER, TARGET :: i
  69   TYPE(c_ptr)     :: a, b(1), c(1,1)
  70   type(c_funptr)  :: fp, fp1(1), fp2(1,1)
  71   a    = C_LOC(i)
  72   b(1) = C_LOC(i)
  73   CALL bar(a)
  74   if (rank /= 0 .or. ctyp /= "c_ptr") stop 1
  75   CALL bar(b)
  76   if (rank /= 1 .or. ctyp /= "c_ptr") stop 2
  77   CALL bar(c)
  78   if (rank /= 2 .or. ctyp /= "c_ptr") stop 3
  79   rank = -99
  80   ctyp = ""
  81   CALL bar((a))
  82   if (rank /= 0 .or. ctyp /= "c_ptr") stop 4
  83   CALL bar((b))
  84   if (rank /= 1 .or. ctyp /= "c_ptr") stop 5
  85   rank = -99
  86   ctyp = ""
  87   CALL bar(fp)
  88   if (rank /= 0 .or. ctyp /= "c_funptr") stop 6
  89   CALL bar(fp1)
  90   if (rank /= 1 .or. ctyp /= "c_funptr") stop 7
  91   rank = -99
  92   ctyp = ""
  93   CALL bar(fp2, a)
  94   if (rank /= -1 .or. ctyp /= "c_funptr") stop 8
  95 END PROGRAM cptr_array_vs_scalar_arg