From: Paul Thomas Date: Fri, 17 Jul 2015 17:23:45 +0000 (+0000) Subject: re PR fortran/52846 ([F2008] Support submodules) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3d5dc929f4077f3d5e8d6fddaa4f196d21a31ebc;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: r225945 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d082f0bd5b6..4c61b1ae0b5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +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 Alessandro Fanfarillo * trans-intrinsic.c (conv_co_collective): Remove redundant address diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 49460613b4a..ebc88eaa5dd 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -6450,6 +6450,11 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; + /* We have to pick out the declared submodule name from the composite + required by F2008:11.2.3 para 2, which ends in the declared name. */ + if (state == COMP_SUBMODULE) + block_name = strchr (block_name, '.') + 1; + if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { gfc_error ("Expected label %qs for %s statement at %C", block_name, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cd0ec885b37..69de5ad7a56 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1556,6 +1556,7 @@ gfc_use_rename; typedef struct gfc_use_list { const char *module_name; + const char *submodule_name; bool intrinsic; bool non_intrinsic; bool only_flag; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index ebfb89bb150..db1d3392811 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -81,6 +81,7 @@ along with GCC; see the file COPYING3. If not see #include #define MODULE_EXTENSION ".mod" +#define SUBMODULE_EXTENSION ".smod" /* Don't put any single quote (') in MOD_VERSION, if you want it to be recognized. */ @@ -190,6 +191,8 @@ static gzFile module_fp; /* The name of the module we're reading (USE'ing) or writing. */ static const char *module_name; +/* The name of the .smod file that the submodule will write to. */ +static const char *submodule_name; static gfc_use_list *module_list; /* If we're reading an intrinsic module, this is its ID. */ @@ -715,7 +718,17 @@ cleanup: } -/* Match a SUBMODULE statement. */ +/* Match a SUBMODULE statement. + + According to F2008:11.2.3.2, "The submodule identifier is the + ordered pair whose first element is the ancestor module name and + whose second element is the submodule name. 'Submodule_name' is + used for the submodule filename and uses '@' as a separator, whilst + the name of the symbol for the module uses '.' as a a separator. + The reasons for these choices are: + (i) To follow another leading brand in the submodule filenames; + (ii) Since '.' is not particularly visible in the filenames; and + (iii) The linker does not permit '@' in mnemonics. */ match gfc_match_submodule (void) @@ -740,7 +753,6 @@ gfc_match_submodule (void) goto syntax; use_list = gfc_get_use_list (); - use_list->module_name = gfc_get_string (name); use_list->where = gfc_current_locus; if (module_list) @@ -749,9 +761,17 @@ gfc_match_submodule (void) while (last->next) last = last->next; last->next = use_list; + use_list->module_name + = gfc_get_string ("%s.%s", module_list->module_name, name); + use_list->submodule_name + = gfc_get_string ("%s@%s", module_list->module_name, name); } else + { module_list = use_list; + use_list->module_name = gfc_get_string (name); + use_list->submodule_name = use_list->module_name; + } if (gfc_match_char (')') == MATCH_YES) break; @@ -764,10 +784,26 @@ gfc_match_submodule (void) if (m != MATCH_YES) goto syntax; + submodule_name = gfc_get_string ("%s@%s", module_list->module_name, + gfc_new_block->name); + + gfc_new_block->name = gfc_get_string ("%s.%s", + module_list->module_name, + gfc_new_block->name); + if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, gfc_new_block->name, NULL)) return MATCH_ERROR; + /* Just retain the ultimate .(s)mod file for reading, since it + contains all the information in its ancestors. */ + use_list = module_list; + for (; module_list->next; use_list = use_list->next) + { + module_list = use_list->next; + free (use_list); + } + return MATCH_YES; syntax: @@ -5932,7 +5968,16 @@ gfc_dump_module (const char *name, int dump_flag) char *filename, *filename_tmp; uLong crc, crc_old; + module_name = gfc_get_string (name); + + if (gfc_state_stack->state == COMP_SUBMODULE) + { + name = submodule_name; + n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; + } + else n = strlen (name) + strlen (MODULE_EXTENSION) + 1; + if (gfc_option.module_dir != NULL) { n += strlen (gfc_option.module_dir); @@ -5945,6 +5990,10 @@ gfc_dump_module (const char *name, int dump_flag) filename = (char *) alloca (n); strcpy (filename, name); } + + if (gfc_state_stack->state == COMP_SUBMODULE) + strcat (filename, SUBMODULE_EXTENSION); + else strcat (filename, MODULE_EXTENSION); /* Name of the temporary file used to write the module. */ @@ -5974,7 +6023,6 @@ gfc_dump_module (const char *name, int dump_flag) /* Write the module itself. */ iomode = IO_OUTPUT; - module_name = gfc_get_string (name); init_pi_tree (); @@ -6705,10 +6753,22 @@ gfc_use_module (gfc_use_list *module) gfc_warning_now (OPT_Wuse_without_only, "USE statement at %C has no ONLY qualifier"); - filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION) - + 1); + if (gfc_state_stack->state == COMP_MODULE + || module->submodule_name == NULL + || strcmp (module_name, module->submodule_name) == 0) + { + filename = XALLOCAVEC (char, strlen (module_name) + + strlen (MODULE_EXTENSION) + 1); strcpy (filename, module_name); strcat (filename, MODULE_EXTENSION); + } + else + { + filename = XALLOCAVEC (char, strlen (module->submodule_name) + + strlen (SUBMODULE_EXTENSION) + 1); + strcpy (filename, module->submodule_name); + strcat (filename, SUBMODULE_EXTENSION); + } /* First, try to find an non-intrinsic module, unless the USE statement specified that the module is intrinsic. */ diff --git a/gcc/testsuite/gfortran.dg/submodule_1.f08 b/gcc/testsuite/gfortran.dg/submodule_1.f08 new file mode 100644 index 00000000000..d117dc6dfd9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_1.f08 @@ -0,0 +1,175 @@ +! { dg-do run } +! +! Basic test of submodule functionality. +! +! Contributed by Paul Thomas +! + module foo_interface + implicit none + character(len = 100) :: message + character(len = 100) :: message2 + + type foo + character(len=15) :: greeting = "Hello, world! " + character(len=15), private :: byebye = "adieu, world! " + contains + procedure :: greet => say_hello + procedure :: farewell => bye + procedure, private :: adieu => byebye + end type foo + + interface + module subroutine say_hello(this) + class(foo), intent(in) :: this + end subroutine + + module subroutine bye(this) + class(foo), intent(in) :: this + end subroutine + + module subroutine byebye(this, that) + class(foo), intent(in) :: this + class(foo), intent(inOUT), allocatable :: that + end subroutine + + module function realf (arg) result (res) + real :: arg, res + end function + + integer module function intf (arg) + integer :: arg + end function + + real module function realg (arg) + real :: arg + end function + + integer module function intg (arg) + integer :: arg + end function + + end interface + + integer :: factor = 5 + + contains + + subroutine smurf + class(foo), allocatable :: this + allocate (this) + message = "say_hello from SMURF --->" + call say_hello (this) + end subroutine + end module + +! + SUBMODULE (foo_interface) foo_interface_son +! + contains +! Test module procedure with conventional specification part for dummies + module subroutine say_hello(this) + class(foo), intent(in) :: this + class(foo), allocatable :: that + allocate (that, source = this) +! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time +! due to recursion through the call to this procedure from +! say hello. + message = that%greeting + +! Check that descendant module procedure is correctly processed + if (intf (77) .ne. factor*77) call abort + end subroutine + + module function realf (arg) result (res) + real :: arg, res + res = 2*arg + end function + + end SUBMODULE foo_interface_son + +! +! Check that multiple generations of submodules are OK + SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson +! + contains + + module procedure intf + intf = factor*arg + end PROCEDURE + + end SUBMODULE foo_interface_grandson + +! + SUBMODULE (foo_interface) foo_interface_daughter +! + contains +! Test module procedure with abbreviated declaration and no specification of dummies + module procedure bye + class(foo), allocatable :: that + call say_hello (this) +! check access to a PRIVATE procedure pointer that accesses a private component + call this%adieu (that) + message2 = that%greeting + end PROCEDURE + +! Test module procedure pointed to by PRIVATE component of foo + module procedure byebye + allocate (that, source = this) +! Access a PRIVATE component of foo + that%greeting = that%byebye + end PROCEDURE + + module procedure intg + intg = 3*arg + end PROCEDURE + + module procedure realg + realg = 3*arg + end PROCEDURE + + end SUBMODULE foo_interface_daughter + +! + program try + use foo_interface + implicit none + type(foo) :: bar + + call clear_messages + call bar%greet ! typebound call + if (trim (message) .ne. "Hello, world!") call abort + + call clear_messages + bar%greeting = "G'day, world!" + call say_hello(bar) ! Checks use association of 'say_hello' + if (trim (message) .ne. "G'day, world!") call abort + + call clear_messages + bar%greeting = "Hi, world!" + call bye(bar) ! Checks use association in another submodule + if (trim (message) .ne. "Hi, world!") call abort + if (trim (message2) .ne. "adieu, world!") call abort + + call clear_messages + call smurf ! Checks host association of 'say_hello' + if (trim (message) .ne. "Hello, world!") call abort + + call clear_messages + bar%greeting = "farewell " + call bar%farewell + if (trim (message) .ne. "farewell") call abort + if (trim (message2) .ne. "adieu, world!") call abort + + if (realf(2.0) .ne. 4.0) call abort ! Check module procedure with explicit result + if (intf(2) .ne. 10) call abort ! ditto + if (realg(3.0) .ne. 9.0) call abort ! Check module procedure with function declaration result + if (intg(3) .ne. 9) call abort ! ditto + contains + subroutine clear_messages + message = "" + message2 = "" + end subroutine + end program +! { dg-final { cleanup-submodules "foo_interface_son" } } +! { dg-final { cleanup-submodules "foo_interface_grandson" } } +! { dg-final { cleanup-submodules "foo_interface_daughter" } } diff --git a/gcc/testsuite/gfortran.dg/submodule_1.f90 b/gcc/testsuite/gfortran.dg/submodule_1.f90 deleted file mode 100644 index 2c5d373206e..00000000000 --- a/gcc/testsuite/gfortran.dg/submodule_1.f90 +++ /dev/null @@ -1,172 +0,0 @@ -! { dg-do run } -! -! Basic test of submodule functionality. -! -! Contributed by Paul Thomas -! - module foo_interface - implicit none - character(len = 100) :: message - character(len = 100) :: message2 - - type foo - character(len=15) :: greeting = "Hello, world! " - character(len=15), private :: byebye = "adieu, world! " - contains - procedure :: greet => say_hello - procedure :: farewell => bye - procedure, private :: adieu => byebye - end type foo - - interface - module subroutine say_hello(this) - class(foo), intent(in) :: this - end subroutine - - module subroutine bye(this) - class(foo), intent(in) :: this - end subroutine - - module subroutine byebye(this, that) - class(foo), intent(in) :: this - class(foo), intent(inOUT), allocatable :: that - end subroutine - - module function realf (arg) result (res) - real :: arg, res - end function - - integer module function intf (arg) - integer :: arg - end function - - real module function realg (arg) - real :: arg - end function - - integer module function intg (arg) - integer :: arg - end function - - end interface - - integer :: factor = 5 - - contains - - subroutine smurf - class(foo), allocatable :: this - allocate (this) - message = "say_hello from SMURF --->" - call say_hello (this) - end subroutine - end module - -! - SUBMODULE (foo_interface) foo_interface_son -! - contains -! Test module procedure with conventional specification part for dummies - module subroutine say_hello(this) - class(foo), intent(in) :: this - class(foo), allocatable :: that - allocate (that, source = this) -! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time -! due to recursion through the call to this procedure from -! say hello. - message = that%greeting - -! Check that descendant module procedure is correctly processed - if (intf (77) .ne. factor*77) call abort - end subroutine - - module function realf (arg) result (res) - real :: arg, res - res = 2*arg - end function - - end SUBMODULE foo_interface_son - -! -! Check that multiple generations of submodules are OK - SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson -! - contains - - module procedure intf - intf = factor*arg - end PROCEDURE - - end SUBMODULE foo_interface_grandson - -! - SUBMODULE (foo_interface) foo_interface_daughter -! - contains -! Test module procedure with abbreviated declaration and no specification of dummies - module procedure bye - class(foo), allocatable :: that - call say_hello (this) -! check access to a PRIVATE procedure pointer that accesses a private component - call this%adieu (that) - message2 = that%greeting - end PROCEDURE - -! Test module procedure pointed to by PRIVATE component of foo - module procedure byebye - allocate (that, source = this) -! Access a PRIVATE component of foo - that%greeting = that%byebye - end PROCEDURE - - module procedure intg - intg = 3*arg - end PROCEDURE - - module procedure realg - realg = 3*arg - end PROCEDURE - - end SUBMODULE foo_interface_daughter - -! - program try - use foo_interface - implicit none - type(foo) :: bar - - call clear_messages - call bar%greet ! typebound call - if (trim (message) .ne. "Hello, world!") call abort - - call clear_messages - bar%greeting = "G'day, world!" - call say_hello(bar) ! Checks use association of 'say_hello' - if (trim (message) .ne. "G'day, world!") call abort - - call clear_messages - bar%greeting = "Hi, world!" - call bye(bar) ! Checks use association in another submodule - if (trim (message) .ne. "Hi, world!") call abort - if (trim (message2) .ne. "adieu, world!") call abort - - call clear_messages - call smurf ! Checks host association of 'say_hello' - if (trim (message) .ne. "Hello, world!") call abort - - call clear_messages - bar%greeting = "farewell " - call bar%farewell - if (trim (message) .ne. "farewell") call abort - if (trim (message2) .ne. "adieu, world!") call abort - - if (realf(2.0) .ne. 4.0) call abort ! Check module procedure with explicit result - if (intf(2) .ne. 10) call abort ! ditto - if (realg(3.0) .ne. 9.0) call abort ! Check module procedure with function declaration result - if (intg(3) .ne. 9) call abort ! ditto - contains - subroutine clear_messages - message = "" - message2 = "" - end subroutine - end program diff --git a/gcc/testsuite/lib/fortran-modules.exp b/gcc/testsuite/lib/fortran-modules.exp index 3ebb31ae115..0e2f30accc4 100644 --- a/gcc/testsuite/lib/fortran-modules.exp +++ b/gcc/testsuite/lib/fortran-modules.exp @@ -29,6 +29,19 @@ proc cleanup-modules { modlist } { } } +# Remove files for specified Fortran submodules. +proc cleanup-submodules { modlist } { + global clean + foreach mod [concat $modlist $clean] { + set m [string tolower $mod].smod + verbose "cleanup-submodule `$m'" 2 + if [is_remote host] { + remote_file host delete $m + } + remote_file build delete $m + } +} + proc keep-modules { modlist } { global clean # if the modlist is empty, keep everything