gcc/testsuite/gfortran.dg/typebound_proc_35.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 78443: [OOP] Incorrect behavior with non_overridable keyword
   4 !
   5 ! Contributed by federico <perini@wisc.edu>
   6
   7 module types
   8     implicit none
   9
  10
  11     ! Abstract parent class and its child type
  12     type, abstract :: P1
  13     contains
  14         procedure :: test => test1
  15         procedure (square_interface), deferred :: square
  16     endtype
  17
  18     ! Deferred procedure interface
  19     abstract interface
  20         function square_interface( this, x ) result( y )
  21            import P1
  22            class(P1) :: this
  23            real :: x, y
  24         end function square_interface
  25     end interface
  26
  27     type, extends(P1) :: C1
  28     contains
  29        procedure, non_overridable :: square => C1_square
  30     endtype
  31
  32     ! Non-abstract parent class and its child type
  33     type :: P2
  34     contains
  35         procedure :: test => test2
  36         procedure :: square => P2_square
  37     endtype
  38
  39     type, extends(P2) :: C2
  40     contains
  41        procedure, non_overridable :: square => C2_square
  42     endtype
  43
  44 contains
  45
  46     real function test1( this, x )
  47         class(P1) :: this
  48         real :: x
  49         test1 = this % square( x )
  50     end function
  51
  52     real function test2( this, x )
  53         class(P2) :: this
  54         real :: x
  55         test2 = this % square( x )
  56     end function
  57
  58     function P2_square( this, x ) result( y )
  59        class(P2) :: this
  60        real :: x, y
  61        y = -100.      ! dummy
  62     end function
  63
  64     function C1_square( this, x ) result( y )
  65        class(C1) :: this
  66        real :: x, y
  67        y = x**2
  68     end function
  69
  70     function C2_square( this, x ) result( y )
  71        class(C2) :: this
  72        real :: x, y
  73        y = x**2
  74     end function
  75
  76 end module
  77
  78 program main
  79     use types
  80     implicit none
  81     type(P2) :: t1
  82     type(C2) :: t2
  83     type(C1) :: t3
  84
  85     if ( t1 % test( 2. ) /= -100.) STOP 1
  86     if ( t2 % test( 2. ) /= 4.) STOP 2
  87     if ( t3 % test( 2. ) /= 4.) STOP 3
  88 end program