gdb/testsuite/gdb.fortran/ptype-on-functions.f90

   1 ! Copyright 2019-2022 Free Software Foundation, Inc.
   2 !
   3 ! This program is free software; you can redistribute it and/or modify
   4 ! it under the terms of the GNU General Public License as published by
   5 ! the Free Software Foundation; either version 3 of the License, or
   6 ! (at your option) any later version.
   7 !
   8 ! This program is distributed in the hope that it will be useful,
   9 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ! GNU General Public License for more details.
  12 !
  13 ! You should have received a copy of the GNU General Public License
  14 ! along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 module some_module
  17   implicit none
  18
  19   type, public :: Number
  20      integer :: a
  21    contains
  22      procedure :: get => get_number
  23      procedure :: set => set_number
  24   end type Number
  25
  26 contains
  27
  28   function get_number (this) result (val)
  29     class (Number), intent (in) :: this
  30     integer :: val
  31     val = this%a
  32   end function get_number
  33
  34   subroutine set_number (this, val)
  35     class (Number), intent (inout) :: this
  36     integer :: val
  37     this%a = val
  38   end subroutine set_number
  39
  40 end module some_module
  41
  42 logical function is_bigger (a,b)
  43   integer, intent(in) :: a
  44   integer, intent(in) :: b
  45   is_bigger = a > b
  46 end function is_bigger
  47
  48 subroutine say_numbers (v1,v2,v3)
  49   integer,intent(in) :: v1
  50   integer,intent(in) :: v2
  51   integer,intent(in) :: v3
  52   print *, v1,v2,v3
  53 end subroutine say_numbers
  54
  55 program test
  56   use some_module
  57
  58   interface
  59      integer function fun1 (x)
  60        integer :: x
  61      end function fun1
  62
  63      integer function fun2 (x)
  64        integer :: x
  65      end function fun2
  66
  67      subroutine say_array (arr)
  68        integer, dimension (:,:) :: arr
  69      end subroutine say_array
  70   end interface
  71
  72   type (Number) :: n1
  73   type (Number) :: n2
  74
  75   procedure(fun1), pointer:: fun_ptr => NULL()
  76
  77   integer, dimension (5,5) :: array
  78   array = 0
  79
  80   call say_numbers (1,2,3)      ! stop here
  81   call say_string ('hello world')
  82   call say_array (array (2:3, 2:4))
  83   print *, fun_ptr (3)
  84
  85 end program test
  86
  87 integer function fun1 (x)
  88   implicit none
  89   integer :: x
  90   fun1 = x + 1
  91 end function fun1
  92
  93 integer function fun2 (x)
  94   implicit none
  95   integer :: x
  96   fun2 = x + 2
  97 end function fun2
  98
  99 subroutine say_string (str)
 100   character(len=*) :: str
 101   print *, str
 102 end subroutine say_string
 103
 104 subroutine say_array (arr)
 105   integer, dimension (:,:) :: arr
 106   do i=LBOUND (arr, 2), UBOUND (arr, 2), 1
 107      do j=LBOUND (arr, 1), UBOUND (arr, 1), 1
 108         write(*, fmt="(i4)", advance="no") arr (j, i)
 109      end do
 110      print *, ""
 111   end do
 112 end subroutine say_array