re PR fortran/52846 ([F2008] Support submodules)

2015-07-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846
	* decl.c (get_proc_name): Make a partially populated interface
	symbol to carry the characteristics of a module procedure and
	its result.
	(variable_decl): Declarations of dummies or results in the
	abreviated form of module procedure is an error.
	(gfc_match_import): IMPORT is not permitted in the interface
	declaration of module procedures.
	(match_attr_spec): Submodule variables have implicit save
	attribute for F2008 onwards.
	(gfc_match_prefix): Add 'module' as the a prefix and set the
	module_procedure attribute.
	(gfc_match_formal_arglist): For a module procedure keep the
	interface formal_arglist from the interface, match new the
	formal arguments and then compare the number and names of each.
	(gfc_match_procedure): Add case COMP_SUBMODULE.
	(gfc_match_function_decl, gfc_match_subroutine_decl): Set the
	module_procedure attribute.
	(gfc_match_entry, gfc_match_end):  Add case COMP_SUBMODULE. If
	attr abr_modproc_decl is set, switch the message accordingly
	for subroutines and functions.
	(gfc_match_submod_proc): New function to match the abbreviated
	style of submodule declaration.
	* gfortran.h : Add ST_SUBMODULE and ST_END_SUBMODULE. Add the
	attribute bits 'used_in_submodule' and 'module_procedure'. Add
	the bit field 'abr_modproc_decl' to gfc_symbol. Add prototypes
	for 'gfc_copy_dummy_sym', 'gfc_check_dummy_characteristics' and
	'gfc_check_result_characteristics'.
	* interface.c : Add the prefix 'gfc_' to the names of functions
	'check_dummy(result)_characteristics' and all their references.
	* match.h : Add prototype for 'gfc_match_submod_proc' and
	'gfc_match_submodule'.
	(check_sym_interfaces): A module procedure is not an error in
	a module procedure statment in a generic interface.
	* module.c (gfc_match_submodule): New function. Add handling
	for the 'module_procedure' attribute bit.
	(gfc_use_module): Make sure that a submodule cannot use itself.
	* parse.c (decode_statement): Set attr has_'import_set' for
	the interface declaration of module procedures. Handle a match
	occurring in 'gfc_match_submod_proc' and a match for
	'submodule'.
	(gfc_enclosing_unit): Include the state COMP_SUBMODULE.
	(gfc_ascii_statement): Add END SUBMODULE.
	(accept_statement): Add ST_SUBMODULE.
	(parse_spec): Disallow statement functions in a submodule
	specification part.
	(parse_contained): Add ST_END_SUBMODULE and COMP_SUBMODULE
	twice each.
	(get_modproc_result): Copy the result symbol of the interface.
	(parse_progunit): Call it.
	(set_syms_host_assoc): Make symbols from the ancestor module
	and submodules use associated, as required by the standard and
	set all private components public. Module procedures 'external'
	attribute bit is reset and the 'used_in_submodule' bit is set.
	(parse_module): If this is a submodule, use the ancestor module
	and submodules. Traverse the namespace, calling
	'set_syms_host_assoc'. Add ST_END_SUBMODULE and COMP_SUBMODULE.
	* parse.h : Add COMP_SUBMODULE.
	* primary.c (match_variable): Add COMP_SUBMODULE.
	* resolve.c (compare_fsyms): New function to compare the dummy
	characteristics of a module procedure with its interface.
	(resolve_fl_procedure): Compare the procedure, result and dummy
	characteristics of a module_procedure with its interface, using
	'compare_fsyms' for the dummy arguments.
	* symbol.c (gfc_add_procedure): Suppress the check for existing
	procedures in the case of a module procedure.
	(gfc_add_explicit_interface): Skip checks that must fail for
	module procedures.
	(gfc_add_type): Allow a new type to be added to module
	procedures, their results or their dummy arguments.
	(gfc_copy_dummy_sym): New function to generate new dummy args
	and copy the characteristics from the interface.
	* trans-decl.c (gfc_sym_mangled_function_id): Module procedures
	must always have their names mangled as if they are symbols
	coming from a declaration in a module.
	(gfc_get_symbol_decl): Add 'used_in_submodule' to the assert.
	(gfc_finish_var_decl): Symbols with the 'used_in_submodule' bit
	set are set DECL_EXTERNAL as if they were use associated.

2015-07-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846
	* gfortran.dg/submodule_1.f90: New test
	* gfortran.dg/submodule_2.f90: New test
	* gfortran.dg/submodule_3.f90: New test
	* gfortran.dg/submodule_4.f90: New test
	* gfortran.dg/submodule_5.f90: New test
	* gfortran.dg/submodule_6.f90: New test
	* gfortran.dg/submodule_7.f90: New test

From-SVN: r225354

1 files changed, 114 insertions, 6 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index c707142..148cff9 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -369,6 +369,16 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
+  if (gfc_match_submod_proc () == MATCH_YES)
+    {
+      if (gfc_new_block->attr.subroutine)
+	return ST_SUBROUTINE;
+      else if (gfc_new_block->attr.function)
+	return ST_FUNCTION;
+    }
+  gfc_undo_symbols ();
+  gfc_current_locus = old_locus;
+
   /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
      statements, which might begin with a block label.  The match functions for
      these statements are unusual in that their keyword is not seen before
@@ -522,6 +532,7 @@ decode_statement (void)
       match ("sequence", gfc_match_eos, ST_SEQUENCE);
       match ("stop", gfc_match_stop, ST_STOP);
       match ("save", gfc_match_save, ST_ATTR_DECL);
+      match ("submodule", gfc_match_submodule, ST_SUBMODULE);
       match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
       match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
       match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
@@ -1534,8 +1545,8 @@ gfc_enclosing_unit (gfc_compile_state * result)
 
   for (p = gfc_state_stack; p; p = p->previous)
     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
-	|| p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
-	|| p->state == COMP_PROGRAM)
+	|| p->state == COMP_MODULE || p->state == COMP_SUBMODULE
+	|| p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
       {
 
 	if (result != NULL)
@@ -1660,6 +1671,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_END_MODULE:
       p = "END MODULE";
       break;
+    case ST_END_SUBMODULE:
+      p = "END SUBMODULE";
+      break;
     case ST_END_PROGRAM:
       p = "END PROGRAM";
       break;
@@ -1742,6 +1756,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_MODULE:
       p = "MODULE";
       break;
+    case ST_SUBMODULE:
+      p = "SUBMODULE";
+      break;
     case ST_PAUSE:
       p = "PAUSE";
       break;
@@ -2186,6 +2203,7 @@ accept_statement (gfc_statement st)
     case ST_FUNCTION:
     case ST_SUBROUTINE:
     case ST_MODULE:
+    case ST_SUBMODULE:
       gfc_current_ns->proc_name = gfc_new_block;
       break;
 
@@ -2931,6 +2949,10 @@ loop:
 	  gfc_free_namespace (gfc_current_ns);
 	  goto loop;
 	}
+      /* F2008 C1210 forbids the IMPORT statement in module procedure
+	 interface bodies and the flag is set to import symbols.  */
+      if (gfc_new_block->attr.module_procedure)
+        gfc_current_ns->has_import_set = 1;
       break;
 
     case ST_PROCEDURE:
@@ -3280,7 +3302,8 @@ declSt:
 	  break;
 
 	case ST_STATEMENT_FUNCTION:
-	  if (gfc_current_state () == COMP_MODULE)
+	  if (gfc_current_state () == COMP_MODULE
+	      || gfc_current_state () == COMP_SUBMODULE)
 	    {
 	      unexpected_statement (st);
 	      break;
@@ -4983,6 +5006,7 @@ parse_contained (int module)
 	/* These statements are associated with the end of the host unit.  */
 	case ST_END_FUNCTION:
 	case ST_END_MODULE:
+	case ST_END_SUBMODULE:
 	case ST_END_PROGRAM:
 	case ST_END_SUBROUTINE:
 	  accept_statement (st);
@@ -4999,7 +5023,8 @@ parse_contained (int module)
 	}
     }
   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
-	 && st != ST_END_MODULE && st != ST_END_PROGRAM);
+	 && st != ST_END_MODULE && st != ST_END_SUBMODULE
+	 && st != ST_END_PROGRAM);
 
   /* The first namespace in the list is guaranteed to not have
      anything (worthwhile) in it.  */
@@ -5019,6 +5044,35 @@ parse_contained (int module)
 }
 
 
+/* The result variable in a MODULE PROCEDURE needs to be created and
+    its characteristics copied from the interface since it is neither
+    declared in the procedure declaration nor in the specification
+    part.  */
+
+static void
+get_modproc_result (void)
+{
+  gfc_symbol *proc;
+  if (gfc_state_stack->previous
+      && gfc_state_stack->previous->state == COMP_CONTAINS
+      && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
+    {
+      proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
+      if (proc != NULL
+	  && proc->attr.function
+	  && proc->ts.interface
+	  && proc->ts.interface->result
+	  && proc->ts.interface->result != proc->ts.interface)
+	{
+	  gfc_copy_dummy_sym (&proc->result, proc->ts.interface->result, 1);
+	  gfc_set_sym_referenced (proc->result);
+	  proc->result->attr.if_source = IFSRC_DECL;
+	  gfc_commit_symbol (proc->result);
+	}
+    }
+}
+
+
 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
 
 static void
@@ -5027,6 +5081,11 @@ parse_progunit (gfc_statement st)
   gfc_state_data *p;
   int n;
 
+  if (gfc_new_block
+      && gfc_new_block->abr_modproc_decl
+      && gfc_new_block->attr.function)
+    get_modproc_result ();
+
   st = parse_spec (st);
   switch (st)
     {
@@ -5086,7 +5145,8 @@ contains:
     if (p->state == COMP_CONTAINS)
       n++;
 
-  if (gfc_find_state (COMP_MODULE) == true)
+  if (gfc_find_state (COMP_MODULE) == true
+      || gfc_find_state (COMP_SUBMODULE) == true)
     n--;
 
   if (n > 0)
@@ -5207,6 +5267,36 @@ parse_block_data (void)
 }
 
 
+/* Following the association of the ancestor (sub)module symbols, they
+   must be set host rather than use associated and all must be public.
+   They are flagged up by 'used_in_submodule' so that they can be set
+   DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl).  Otherwise the
+   linker chokes on multiple symbol definitions.  */
+
+static void
+set_syms_host_assoc (gfc_symbol *sym)
+{
+  gfc_component *c;
+
+  if (sym == NULL)
+    return;
+
+  if (sym->attr.module_procedure)
+    sym->attr.external = 0;
+
+/*  sym->attr.access = ACCESS_PUBLIC;  */
+
+  sym->attr.use_assoc = 0;
+  sym->attr.host_assoc = 1;
+  sym->attr.used_in_submodule =1;
+
+  if (sym->attr.flavor == FL_DERIVED)
+    {
+      for (c = sym->components; c; c = c->next)
+	c->attr.access = ACCESS_PUBLIC;
+    }
+}
+
 /* Parse a module subprogram.  */
 
 static void
@@ -5226,6 +5316,15 @@ parse_module (void)
       s->defined = 1;
     }
 
+  /* Something is nulling the module_list after this point. This is good
+     since it allows us to 'USE' the parent modules that the submodule
+     inherits and to set (most) of the symbols as host associated.  */
+  if (gfc_current_state () == COMP_SUBMODULE)
+    {
+      use_modules ();
+      gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
+    }
+
   st = parse_spec (ST_NONE);
 
   error = false;
@@ -5240,6 +5339,7 @@ loop:
       break;
 
     case ST_END_MODULE:
+    case ST_END_SUBMODULE:
       accept_statement (st);
       break;
 
@@ -5535,6 +5635,14 @@ loop:
       parse_module ();
       break;
 
+    case ST_SUBMODULE:
+      push_state (&s, COMP_SUBMODULE, gfc_new_block);
+      accept_statement (st);
+
+      gfc_get_errors (NULL, &errors_before);
+      parse_module ();
+      break;
+
     /* Anything else starts a nameless main program block.  */
     default:
       if (seen_program)
@@ -5559,7 +5667,7 @@ loop:
     gfc_dump_parse_tree (gfc_current_ns, stdout);
 
   gfc_get_errors (NULL, &errors);
-  if (s.state == COMP_MODULE)
+  if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
     {
       gfc_dump_module (s.sym->name, errors_before == errors);
       gfc_current_ns->derived_types = gfc_derived_types;