From: Paul Thomas Date: Fri, 17 Jul 2015 17:26:42 +0000 (+0000) Subject: re PR fortran/52846 ([F2008] Support submodules) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d0e8d89223cf24f067ddca3e01842374765af89a;p=gcc.git re PR fortran/52846 ([F2008] Support submodules) 2015-07-17 Paul Thomas PR fortran/52846 * decl.c (gfc_match_end): Pick out declared submodule name from the composite identifier. * gfortran.h : Add 'submodule_name' to gfc_use_list structure. * module.c (gfc_match_submodule): Define submodule_name and add static 'submodule_name'. (gfc_match_submodule): Build up submodule filenames, using '@' as a delimiter. Store the output filename in 'submodule_name'. Similarly, the submodule identifier is built using '.' as an identifier. (gfc_dump_module): If current state is COMP_SUBMODULE, write to file 'submodule_name', using SUBMODULE_EXTENSION. (gfc_use_module): Similarly, use the 'submodule_name' field in the gfc_use_list structure and SUBMODULE_EXTENSION to read the implicitly used submodule files. 2015-07-17 Paul Thomas PR fortran/52846 * lib/fortran-modules.exp (proc cleanup-submodules): New procedure. * gfortran.dg/submodule_1.f08: Change extension and clean up the submodule files. * gfortran.dg/submodule_2.f08: ditto * gfortran.dg/submodule_6.f08: ditto * gfortran.dg/submodule_7.f08: ditto * gfortran.dg/submodule_8.f08: New test * gfortran.dg/submodule_9.f08: New test From-SVN: r225956 --- diff --git a/gcc/testsuite/gfortran.dg/submodule_7.f08 b/gcc/testsuite/gfortran.dg/submodule_7.f08 new file mode 100644 index 00000000000..a183f50e46c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_7.f08 @@ -0,0 +1,149 @@ +! { dg-do run } +! +! Example in F2008 C.8.4 to demonstrate submodules +! +module color_points + type color_point + private + real :: x, y + integer :: color + end type color_point + + interface +! Interfaces for procedures with separate +! bodies in the submodule color_points_a + module subroutine color_point_del ( p ) ! Destroy a color_point object + type(color_point), allocatable :: p + end subroutine color_point_del +! Distance between two color_point objects + real module function color_point_dist ( a, b ) + type(color_point), intent(in) :: a, b + end function color_point_dist + module subroutine color_point_draw ( p ) ! Draw a color_point object + type(color_point), intent(in) :: p + end subroutine color_point_draw + module subroutine color_point_new ( p ) ! Create a color_point object + type(color_point), allocatable :: p + end subroutine color_point_new + module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects + type(color_point), allocatable :: p1, p2 + end subroutine verify_cleanup + end interface +end module color_points + +module palette_stuff + type :: palette ; +!... + end type palette +contains + subroutine test_palette ( p ) +! Draw a color wheel using procedures from the color_points module + use color_points ! This does not cause a circular dependency because +! the "use palette_stuff" that is logically within +! color_points is in the color_points_a submodule. + type(palette), intent(in) :: p + end subroutine test_palette +end module palette_stuff + + +submodule ( color_points ) color_points_a ! Submodule of color_points + integer :: instance_count = 0 + interface +! Interface for a procedure with a separate +! body in submodule color_points_b + module subroutine inquire_palette ( pt, pal ) + use palette_stuff +! palette_stuff, especially submodules +! thereof, can reference color_points by use +! association without causing a circular +! dependence during translation because this +! use is not in the module. Furthermore, +! changes in the module palette_stuff do not +! affect the translation of color_points. + type(color_point), intent(in) :: pt + type(palette), intent(out) :: pal + end subroutine inquire_palette + end interface +contains +! Invisible bodies for public separate module procedures +! declared in the module + module subroutine color_point_del ( p ) + type(color_point), allocatable :: p + instance_count = instance_count - 1 + deallocate ( p ) + end subroutine color_point_del + real module function color_point_dist ( a, b ) result ( dist ) + type(color_point), intent(in) :: a, b + dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 ) + end function color_point_dist + module subroutine color_point_new ( p ) + type(color_point), allocatable :: p + instance_count = instance_count + 1 + allocate ( p ) +! Added to example so that it does something. + p%x = real (instance_count) * 1.0 + p%y = real (instance_count) * 2.0 + p%color = instance_count + end subroutine color_point_new +end submodule color_points_a + + +submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule + +contains +! Invisible body for interface declared in the ancestor module + module subroutine color_point_draw ( p ) + use palette_stuff, only: palette + type(color_point), intent(in) :: p + type(palette) :: MyPalette + call inquire_palette ( p, MyPalette ) +! Added to example so that it does something. + if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) call abort + if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) call abort + end subroutine color_point_draw +! Invisible body for interface declared in the parent submodule + module procedure inquire_palette +!... implementation of inquire_palette + end procedure inquire_palette + module procedure verify_cleanup + if (allocated (p1) .or. allocated (p2)) call abort + if (instance_count .ne. 0) call abort + end procedure + subroutine private_stuff ! not accessible from color_points_a +!... + end subroutine private_stuff +end submodule color_points_b + + +program main + use color_points +! "instance_count" and "inquire_palette" are not accessible here +! because they are not declared in the "color_points" module. +! "color_points_a" and "color_points_b" cannot be referenced by +! use association. + interface draw +! just to demonstrate it’s possible + module procedure color_point_draw + end interface + type(color_point), allocatable :: C_1, C_2 + real :: RC +!... + call color_point_new (c_1) + call color_point_new (c_2) +! body in color_points_a, interface in color_points +!... + call draw (c_1) +! body in color_points_b, specific interface +! in color_points, generic interface here. +!... + rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points + if (abs (rc - 2.23606801) .gt. 1.0e-6) call abort +!... + call color_point_del (c_1) + call color_point_del (c_2) +! body in color_points_a, interface in color_points + call verify_cleanup (c_1, c_2) +!... +end program main +! { dg-final { cleanup-submodules "color_points@color_points_a" } } +! { dg-final { cleanup-submodules "color_points@color_points_b" } } diff --git a/gcc/testsuite/gfortran.dg/submodule_7.f90 b/gcc/testsuite/gfortran.dg/submodule_7.f90 deleted file mode 100644 index fd1bee6296c..00000000000 --- a/gcc/testsuite/gfortran.dg/submodule_7.f90 +++ /dev/null @@ -1,147 +0,0 @@ -! { dg-do run } -! -! Example in F2008 C.8.4 to demonstrate submodules -! -module color_points - type color_point - private - real :: x, y - integer :: color - end type color_point - - interface -! Interfaces for procedures with separate -! bodies in the submodule color_points_a - module subroutine color_point_del ( p ) ! Destroy a color_point object - type(color_point), allocatable :: p - end subroutine color_point_del -! Distance between two color_point objects - real module function color_point_dist ( a, b ) - type(color_point), intent(in) :: a, b - end function color_point_dist - module subroutine color_point_draw ( p ) ! Draw a color_point object - type(color_point), intent(in) :: p - end subroutine color_point_draw - module subroutine color_point_new ( p ) ! Create a color_point object - type(color_point), allocatable :: p - end subroutine color_point_new - module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects - type(color_point), allocatable :: p1, p2 - end subroutine verify_cleanup - end interface -end module color_points - -module palette_stuff - type :: palette ; -!... - end type palette -contains - subroutine test_palette ( p ) -! Draw a color wheel using procedures from the color_points module - use color_points ! This does not cause a circular dependency because -! the "use palette_stuff" that is logically within -! color_points is in the color_points_a submodule. - type(palette), intent(in) :: p - end subroutine test_palette -end module palette_stuff - - -submodule ( color_points ) color_points_a ! Submodule of color_points - integer :: instance_count = 0 - interface -! Interface for a procedure with a separate -! body in submodule color_points_b - module subroutine inquire_palette ( pt, pal ) - use palette_stuff -! palette_stuff, especially submodules -! thereof, can reference color_points by use -! association without causing a circular -! dependence during translation because this -! use is not in the module. Furthermore, -! changes in the module palette_stuff do not -! affect the translation of color_points. - type(color_point), intent(in) :: pt - type(palette), intent(out) :: pal - end subroutine inquire_palette - end interface -contains -! Invisible bodies for public separate module procedures -! declared in the module - module subroutine color_point_del ( p ) - type(color_point), allocatable :: p - instance_count = instance_count - 1 - deallocate ( p ) - end subroutine color_point_del - real module function color_point_dist ( a, b ) result ( dist ) - type(color_point), intent(in) :: a, b - dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 ) - end function color_point_dist - module subroutine color_point_new ( p ) - type(color_point), allocatable :: p - instance_count = instance_count + 1 - allocate ( p ) -! Added to example so that it does something. - p%x = real (instance_count) * 1.0 - p%y = real (instance_count) * 2.0 - p%color = instance_count - end subroutine color_point_new -end submodule color_points_a - - -submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule - -contains -! Invisible body for interface declared in the ancestor module - module subroutine color_point_draw ( p ) - use palette_stuff, only: palette - type(color_point), intent(in) :: p - type(palette) :: MyPalette - call inquire_palette ( p, MyPalette ) -! Added to example so that it does something. - if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) call abort - if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) call abort - end subroutine color_point_draw -! Invisible body for interface declared in the parent submodule - module procedure inquire_palette -!... implementation of inquire_palette - end procedure inquire_palette - module procedure verify_cleanup - if (allocated (p1) .or. allocated (p2)) call abort - if (instance_count .ne. 0) call abort - end procedure - subroutine private_stuff ! not accessible from color_points_a -!... - end subroutine private_stuff -end submodule color_points_b - - -program main - use color_points -! "instance_count" and "inquire_palette" are not accessible here -! because they are not declared in the "color_points" module. -! "color_points_a" and "color_points_b" cannot be referenced by -! use association. - interface draw -! just to demonstrate it’s possible - module procedure color_point_draw - end interface - type(color_point), allocatable :: C_1, C_2 - real :: RC -!... - call color_point_new (c_1) - call color_point_new (c_2) -! body in color_points_a, interface in color_points -!... - call draw (c_1) -! body in color_points_b, specific interface -! in color_points, generic interface here. -!... - rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points - if (abs (rc - 2.23606801) .gt. 1.0e-6) call abort -!... - call color_point_del (c_1) - call color_point_del (c_2) -! body in color_points_a, interface in color_points - call verify_cleanup (c_1, c_2) -!... -end program main