gcc/testsuite/gfortran.dg/submodule_7.f08

   1 ! { dg-do run }
   2 !
   3 ! Example in F2008 C.8.4 to demonstrate submodules
   4 !
   5 module color_points
   6   type color_point
   7     private
   8     real :: x, y
   9     integer :: color
  10   end type color_point
  11
  12   interface
  13 ! Interfaces for procedures with separate
  14 ! bodies in the submodule color_points_a
  15     module subroutine color_point_del ( p ) ! Destroy a color_point object
  16       type(color_point), allocatable :: p
  17     end subroutine color_point_del
  18 ! Distance between two color_point objects
  19     real module function color_point_dist ( a, b )
  20       type(color_point), intent(in) :: a, b
  21     end function color_point_dist
  22     module subroutine color_point_draw ( p ) ! Draw a color_point object
  23       type(color_point), intent(in) :: p
  24     end subroutine color_point_draw
  25     module subroutine color_point_new ( p ) ! Create a color_point object
  26       type(color_point), allocatable :: p
  27     end subroutine color_point_new
  28     module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects
  29       type(color_point), allocatable :: p1, p2
  30     end subroutine verify_cleanup
  31   end interface
  32 end module color_points
  33
  34 module palette_stuff
  35   type :: palette ;
  36 !...
  37   end type palette
  38 contains
  39   subroutine test_palette ( p )
  40 ! Draw a color wheel using procedures from the color_points module
  41     use color_points ! This does not cause a circular dependency because
  42 ! the "use palette_stuff" that is logically within
  43 ! color_points is in the color_points_a submodule.
  44     type(palette), intent(in) :: p
  45   end subroutine test_palette
  46 end module palette_stuff
  47
  48
  49 submodule ( color_points ) color_points_a ! Submodule of color_points
  50   integer :: instance_count = 0
  51   interface
  52 ! Interface for a procedure with a separate
  53 ! body in submodule color_points_b
  54     module subroutine inquire_palette ( pt, pal )
  55       use palette_stuff
  56 ! palette_stuff, especially submodules
  57 ! thereof, can reference color_points by use
  58 ! association without causing a circular
  59 ! dependence during translation because this
  60 ! use is not in the module. Furthermore,
  61 ! changes in the module palette_stuff do not
  62 ! affect the translation of color_points.
  63       type(color_point), intent(in) :: pt
  64       type(palette), intent(out) :: pal
  65     end subroutine inquire_palette
  66   end interface
  67 contains
  68 ! Invisible bodies for public separate module procedures
  69 ! declared in the module
  70   module subroutine color_point_del ( p )
  71     type(color_point), allocatable :: p
  72     instance_count = instance_count - 1
  73     deallocate ( p )
  74   end subroutine color_point_del
  75   real module function color_point_dist ( a, b ) result ( dist )
  76     type(color_point), intent(in) :: a, b
  77     dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 )
  78   end function color_point_dist
  79   module subroutine color_point_new ( p )
  80     type(color_point), allocatable :: p
  81     instance_count = instance_count + 1
  82     allocate ( p )
  83 ! Added to example so that it does something.
  84     p%x = real (instance_count) * 1.0
  85     p%y = real (instance_count) * 2.0
  86     p%color = instance_count
  87   end subroutine color_point_new
  88 end submodule color_points_a
  89
  90
  91 submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule
  92
  93 contains
  94 ! Invisible body for interface declared in the ancestor module
  95   module subroutine color_point_draw ( p )
  96     use palette_stuff, only: palette
  97     type(color_point), intent(in) :: p
  98     type(palette) :: MyPalette
  99     call inquire_palette ( p, MyPalette )
 100 ! Added to example so that it does something.
 101     if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) STOP 1
 102     if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) STOP 2
 103   end subroutine color_point_draw
 104 ! Invisible body for interface declared in the parent submodule
 105   module procedure inquire_palette
 106 !... implementation of inquire_palette
 107   end procedure inquire_palette
 108   module procedure verify_cleanup
 109     if (allocated (p1) .or. allocated (p2)) STOP 3
 110     if (instance_count .ne. 0) STOP 4
 111   end procedure
 112   subroutine private_stuff ! not accessible from color_points_a
 113 !...
 114   end subroutine private_stuff
 115 end submodule color_points_b
 116
 117
 118 program main
 119   use color_points
 120 ! "instance_count" and "inquire_palette" are not accessible here
 121 ! because they are not declared in the "color_points" module.
 122 ! "color_points_a" and "color_points_b" cannot be referenced by
 123 ! use association.
 124   interface draw
 125 ! just to demonstrate it’s possible
 126     module procedure color_point_draw
 127   end interface
 128   type(color_point), allocatable :: C_1, C_2
 129   real :: RC
 130 !...
 131   call color_point_new (c_1)
 132   call color_point_new (c_2)
 133 ! body in color_points_a, interface in color_points
 134 !...
 135   call draw (c_1)
 136 ! body in color_points_b, specific interface
 137 ! in color_points, generic interface here.
 138 !...
 139   rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points
 140   if (abs (rc - 2.23606801) .gt. 1.0e-6) STOP 5
 141 !...
 142   call color_point_del (c_1)
 143   call color_point_del (c_2)
 144 ! body in color_points_a, interface in color_points
 145   call verify_cleanup (c_1, c_2)
 146 !...
 147 end program main