gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected
   4 !
   5 ! Original test case by Arjen Markus <arjen.markus895@gmail.com>
   6 ! Modified by Janus Weil <janus@gcc.gnu.org>
   7
   8 module m
   9
  10   implicit none
  11
  12   type :: rectangle
  13     real :: width, height
  14     procedure(get_area_ai), pointer :: get_area => get_my_area  ! { dg-error "Type/rank mismatch" }
  15   end type rectangle
  16
  17   abstract interface
  18     real function get_area_ai( this )
  19       import                       :: rectangle
  20       class(rectangle), intent(in) :: this
  21     end function get_area_ai
  22   end interface
  23
  24 contains
  25
  26   real function get_my_area( this )
  27     type(rectangle), intent(in) :: this
  28     get_my_area = 3.0 * this%width * this%height
  29   end function get_my_area
  30
  31 end
  32
  33 !-------------------------------------------------------------------------------
  34
  35 program p
  36
  37   implicit none
  38
  39   type :: rectangle
  40     real :: width, height
  41     procedure(get_area_ai), pointer :: get_area
  42   end type rectangle
  43
  44   abstract interface
  45     real function get_area_ai (this)
  46       import                       :: rectangle
  47       class(rectangle), intent(in) :: this
  48     end function get_area_ai
  49   end interface
  50
  51   type(rectangle) :: rect
  52
  53   rect  = rectangle (1.0, 2.0, get1)
  54   rect  = rectangle (3.0, 4.0, get2)  ! { dg-error "Type/rank mismatch" }
  55
  56 contains
  57
  58   real function get1 (this)
  59     class(rectangle), intent(in) :: this
  60     get1 = 1.0 * this%width * this%height
  61   end function get1
  62
  63   real function get2 (this)
  64     type(rectangle), intent(in) :: this
  65     get2 = 2.0 * this%width * this%height
  66   end function get2
  67
  68 end
  69
  70
  71 ! { dg-final { cleanup-modules "m" } }