[FORTRAN,v2] Use stringpool on loading module symbols
diff mbox series

Message ID 20180919225533.20009-1-rep.dot.nop@gmail.com
State New
Headers show
Series
  • [FORTRAN,v2] Use stringpool on loading module symbols
Related show

Commit Message

Bernhard Reutner-Fischer Sept. 19, 2018, 10:55 p.m. UTC
From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2018-09-19  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* class.c (generate_finalization_wrapper, gfc_find_derived_vtab,
	find_intrinsic_vtab): Set module if in module context.
	* decl.c (gfc_match_decl_type_spec): Likewise.
	(match_procedure_decl, match_ppc_decl): Flag interface function
	as artificial.
	* resolve.c (check_proc_interface): Do not warn about missing
	explicit interface for artificial interface functions.
	* module.c (free_pi_tree): Do not free true_name nor module.
	(parse_string): Avoid needless reallocation.
	(read_string): Delete.
	(read_module): Use stringpool when generating symbols and module
	names.
	(mio_symtree_ref): Use stringpool for module.
	(mio_omp_udr_expr): Likewise.
	(load_needed): Use stringpool for module and symbol name.
	(find_symbols_to_write): Fix indentation.
---
 gcc/fortran/class.c   | 18 ++++++++-
 gcc/fortran/decl.c    |  8 ++++
 gcc/fortran/module.c  | 92 +++++++++++++++++++------------------------
 gcc/fortran/resolve.c |  2 +-
 4 files changed, 65 insertions(+), 55 deletions(-)

Patch
diff mbox series

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 33c772c6eba..370b6387744 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1641,6 +1641,8 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   array->as->type = AS_ASSUMED_RANK;
   array->as->rank = -1;
   array->attr.intent = INTENT_INOUT;
+  if (ns->proc_name->attr.flavor == FL_MODULE)
+    array->module = ns->proc_name->name;
   gfc_set_sym_referenced (array);
   final->formal = gfc_get_formal_arglist ();
   final->formal->sym = array;
@@ -1654,6 +1656,8 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   byte_stride->attr.dummy = 1;
   byte_stride->attr.value = 1;
   byte_stride->attr.artificial = 1;
+  if (ns->proc_name->attr.flavor == FL_MODULE)
+    byte_stride->module = ns->proc_name->name;
   gfc_set_sym_referenced (byte_stride);
   final->formal->next = gfc_get_formal_arglist ();
   final->formal->next->sym = byte_stride;
@@ -1667,6 +1671,8 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   fini_coarray->attr.dummy = 1;
   fini_coarray->attr.value = 1;
   fini_coarray->attr.artificial = 1;
+  if (ns->proc_name->attr.flavor == FL_MODULE)
+    fini_coarray->module = ns->proc_name->name;
   gfc_set_sym_referenced (fini_coarray);
   final->formal->next->next = gfc_get_formal_arglist ();
   final->formal->next->next->sym = fini_coarray;
@@ -2432,7 +2438,9 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  src->attr.flavor = FL_VARIABLE;
 		  src->attr.dummy = 1;
 		  src->attr.artificial = 1;
-     		  src->attr.intent = INTENT_IN;
+		  src->attr.intent = INTENT_IN;
+		  if (ns->proc_name->attr.flavor == FL_MODULE)
+		    src->module = sub_ns->proc_name->name;
 		  gfc_set_sym_referenced (src);
 		  copy->formal = gfc_get_formal_arglist ();
 		  copy->formal->sym = src;
@@ -2443,6 +2451,8 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  dst->attr.dummy = 1;
 		  dst->attr.artificial = 1;
 		  dst->attr.intent = INTENT_INOUT;
+		  if (ns->proc_name->attr.flavor == FL_MODULE)
+		    dst->module = sub_ns->proc_name->name;
 		  gfc_set_sym_referenced (dst);
 		  copy->formal->next = gfc_get_formal_arglist ();
 		  copy->formal->next->sym = dst;
@@ -2761,7 +2771,7 @@  find_intrinsic_vtab (gfc_typespec *ts)
 	      copy->attr.elemental = 1;
 	      if (ns->proc_name->attr.flavor == FL_MODULE)
 		copy->module = ns->proc_name->name;
-		  gfc_set_sym_referenced (copy);
+	      gfc_set_sym_referenced (copy);
 	      /* Set up formal arguments.  */
 	      gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
 	      src->ts.type = ts->type;
@@ -2769,6 +2779,8 @@  find_intrinsic_vtab (gfc_typespec *ts)
 	      src->attr.flavor = FL_VARIABLE;
 	      src->attr.dummy = 1;
 	      src->attr.intent = INTENT_IN;
+	      if (ns->proc_name->attr.flavor == FL_MODULE)
+		src->module = sub_ns->proc_name->name;
 	      gfc_set_sym_referenced (src);
 	      copy->formal = gfc_get_formal_arglist ();
 	      copy->formal->sym = src;
@@ -2778,6 +2790,8 @@  find_intrinsic_vtab (gfc_typespec *ts)
 	      dst->attr.flavor = FL_VARIABLE;
 	      dst->attr.dummy = 1;
 	      dst->attr.intent = INTENT_INOUT;
+	      if (ns->proc_name->attr.flavor == FL_MODULE)
+		dst->module = sub_ns->proc_name->name;
 	      gfc_set_sym_referenced (dst);
 	      copy->formal->next = gfc_get_formal_arglist ();
 	      copy->formal->next->sym = dst;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 1f148c88eb8..018af363679 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4061,6 +4061,10 @@  gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	      upe->refs++;
 	      upe->ts.type = BT_VOID;
 	      upe->attr.unlimited_polymorphic = 1;
+	      /* Make sure gfc_find_gsymbol sees a (non-NULL) name to
+	       * search for by plugging in some module name.  */
+	      if (gfc_current_ns->proc_name != NULL)
+		upe->module = gfc_current_ns->proc_name->name;
 	      /* This is essential to force the construction of
 		 unlimited polymorphic component class containers.  */
 	      upe->attr.zero_comp = 1;
@@ -6681,6 +6685,8 @@  match_procedure_decl (void)
 	  sym->ts.interface->ts = current_ts;
 	  sym->ts.interface->attr.flavor = FL_PROCEDURE;
 	  sym->ts.interface->attr.function = 1;
+	  /* Suppress warnings about explicit interface */
+	  sym->ts.interface->attr.artificial = 1;
 	  sym->attr.function = 1;
 	  sym->attr.if_source = IFSRC_UNKNOWN;
 	}
@@ -6820,6 +6826,8 @@  match_ppc_decl (void)
 	  c->ts.interface->ts = ts;
 	  c->ts.interface->attr.flavor = FL_PROCEDURE;
 	  c->ts.interface->attr.function = 1;
+	  /* Suppress warnings about explicit interface */
+	  c->ts.interface->attr.artificial = 1;
 	  c->attr.function = 1;
 	  c->attr.if_source = IFSRC_UNKNOWN;
 	}
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8f6dc9f2864..3cc8e80dc56 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -159,7 +159,7 @@  typedef struct pointer_info
     {
       gfc_symbol *sym;
       const char *binding_label;
-      char *true_name, *module;
+      const char *true_name, *module;
       fixup_t *stfixup;
       gfc_symtree *symtree;
       enum gfc_rsym_state state;
@@ -239,12 +239,6 @@  free_pi_tree (pointer_info *p)
   free_pi_tree (p->left);
   free_pi_tree (p->right);
 
-  if (iomode == IO_INPUT)
-    {
-      XDELETEVEC (p->u.rsym.true_name);
-      XDELETEVEC (p->u.rsym.module);
-    }
-
   free (p);
 }
 
@@ -1271,8 +1265,9 @@  parse_string (void)
       len++;
     }
 
-  atom_string = XRESIZEVEC (char, atom_string, len + 1);
-  atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
+  if (len >= cursz)
+    atom_string = XRESIZEVEC (char, atom_string, len + 1);
+  atom_string[len] = '\0';	/* C-style string for debug purposes.  */
 }
 
 
@@ -1594,19 +1589,6 @@  find_enum (const mstring *m)
 }
 
 
-/* Read a string. The caller is responsible for freeing.  */
-
-static char*
-read_string (void)
-{
-  char* p;
-  require_atom (ATOM_STRING);
-  p = atom_string;
-  atom_string = NULL;
-  return p;
-}
-
-
 /**************** Module output subroutines ***************************/
 
 /* Output a character to a module file.  */
@@ -3013,7 +2995,7 @@  mio_symtree_ref (gfc_symtree **stp)
 	    {
 	      p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
 					      gfc_current_ns);
-	      p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
+	      p->u.rsym.sym->module = p->u.rsym.module;
 	    }
 
 	  p->u.rsym.symtree->n.sym = p->u.rsym.sym;
@@ -4242,13 +4224,13 @@  mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
       q->u.pointer = (void *) ns;
       sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
       sym->ts = udr->ts;
-      sym->module = gfc_get_string ("%s", p1->u.rsym.module);
+      sym->module = p1->u.rsym.module;
       associate_integer_pointer (p1, sym);
       sym->attr.omp_udr_artificial_var = 1;
       gcc_assert (p2->u.rsym.sym == NULL);
       sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
       sym->ts = udr->ts;
-      sym->module = gfc_get_string ("%s", p2->u.rsym.module);
+      sym->module = p2->u.rsym.module;
       associate_integer_pointer (p2, sym);
       sym->attr.omp_udr_artificial_var = 1;
       if (mio_name (0, omp_declare_reduction_stmt) == 0)
@@ -4371,8 +4353,8 @@  mio_symbol (gfc_symbol *sym)
 /************************* Top level subroutines *************************/
 
 /* A recursive function to look for a specific symbol by name and by
-   module.  Whilst several symtrees might point to one symbol, its
-   is sufficient for the purposes here than one exist.  Note that
+   module.  Whilst several symtrees might point to one symbol, it
+   is sufficient for the purposes here that one exist.  Note that
    generic interfaces are distinguished as are symbols that have been
    renamed in another module.  */
 static gfc_symtree *
@@ -4890,15 +4872,24 @@  load_needed (pointer_info *p)
 
       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
 	 doesn't go pear-shaped if the symbol is used.  */
-      if (!ns->proc_name)
-	gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
-				 1, &ns->proc_name);
+      if (ns->proc_name == NULL && p->u.rsym.module != NULL)
+	    gfc_find_symbol (p->u.rsym.module,
+			 gfc_current_ns, 1, &ns->proc_name);
+      if (p->u.rsym.true_name != NULL)
+	{
+	  sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+	  sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
+	}
+      else
+	{
+	  static unsigned int fake = 0;
+	  const char *fake_node;
 
-      sym = gfc_new_symbol (p->u.rsym.true_name, ns);
-      sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
-      sym->module = gfc_get_string ("%s", p->u.rsym.module);
-      if (p->u.rsym.binding_label)
-	sym->binding_label = p->u.rsym.binding_label;
+	  fake_node = gfc_get_string ("__fake_fixup_node_%d", fake++);
+	  sym = gfc_new_symbol (fake_node, ns);
+	}
+      sym->module = p->u.rsym.module;
+      sym->binding_label = p->u.rsym.binding_label;
 
       associate_integer_pointer (p, sym);
     }
@@ -5073,18 +5064,15 @@  read_module (void)
 
   while (peek_atom () != ATOM_RPAREN)
     {
-      const char* bind_label;
       require_atom (ATOM_INTEGER);
       info = get_integer (atom_int);
 
       info->type = P_SYMBOL;
       info->u.rsym.state = UNUSED;
 
-      info->u.rsym.true_name = read_string ();
-      info->u.rsym.module = read_string ();
-      mio_pool_string (&bind_label);
-      if (bind_label)
-	info->u.rsym.binding_label = bind_label;
+      mio_pool_string (&info->u.rsym.true_name);
+      mio_pool_string (&info->u.rsym.module);
+      mio_pool_string (&info->u.rsym.binding_label);
 
       require_atom (ATOM_INTEGER);
       info->u.rsym.ns = atom_int;
@@ -5096,10 +5084,13 @@  read_module (void)
 	 being loaded again.  This should not happen if the symbol being
 	 read is an index for an assumed shape dummy array (ns != 1).  */
 
-      sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
+      if (info->u.rsym.true_name == NULL || info->u.rsym.module == NULL)
+	sym = NULL;
+      else
+	sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
 
       if (sym == NULL
-	  || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
+	  || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns != 1))
 	{
 	  skip_list ();
 	  continue;
@@ -5254,14 +5245,11 @@  read_module (void)
 	      /* Create a symbol node if it doesn't already exist.  */
 	      if (sym == NULL)
 		{
-		  info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
-						     gfc_current_ns);
-		  info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
-		  sym = info->u.rsym.sym;
-		  sym->module = gfc_get_string ("%s", info->u.rsym.module);
-
-		  if (info->u.rsym.binding_label)
-		    sym->binding_label = info->u.rsym.binding_label;
+		  sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
+		  sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
+		  sym->module = info->u.rsym.module;
+		  sym->binding_label = info->u.rsym.binding_label;
+		  info->u.rsym.sym = sym;
 		}
 
 	      st->n.sym = sym;
@@ -5795,7 +5783,7 @@  find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
       sp->p = p;
 
       gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
-   }
+    }
 
   find_symbols_to_write (tree, p->left);
   find_symbols_to_write (tree, p->right);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8072bd20435..34ecc9e669f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -173,7 +173,7 @@  check_proc_interface (gfc_symbol *ifc, locus *where)
 		 "PROCEDURE statement at %L", ifc->name, where);
       return false;
     }
-  if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+  if (!ifc->attr.if_source && !ifc->attr.intrinsic && !ifc->attr.artificial)
     {
       gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
       return false;