+2015-07-17 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <fanfarillo.gcc@gmail.com>
* trans-intrinsic.c (conv_co_collective): Remove redundant address
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,
typedef struct gfc_use_list
{
const char *module_name;
+ const char *submodule_name;
bool intrinsic;
bool non_intrinsic;
bool only_flag;
#include <zlib.h>
#define MODULE_EXTENSION ".mod"
+#define SUBMODULE_EXTENSION ".smod"
/* Don't put any single quote (') in MOD_VERSION, if you want it to be
recognized. */
/* 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. */
}
-/* 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)
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)
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;
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:
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);
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. */
/* Write the module itself. */
iomode = IO_OUTPUT;
- module_name = gfc_get_string (name);
init_pi_tree ();
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. */
--- /dev/null
+! { dg-do run }
+!
+! Basic test of submodule functionality.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ 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" } }
+++ /dev/null
-! { dg-do run }
-!
-! Basic test of submodule functionality.
-!
-! Contributed by Paul Thomas <pault@gcc.gnu.org>
-!
- 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
}
}
+# 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
projects / gcc.git / commitdiff