[PATCH] Derive interface buffers from max name length

[PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

These three function used a hardcoded buffer of 100 but would be better
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
name in any of our supported standards (63 as of f2003 ff.).

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* interface.c (check_sym_interfaces, check_uop_interfaces,
	gfc_check_interfaces): Base interface_name buffer off
	GFC_MAX_SYMBOL_LEN.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/interface.c | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dcf3eae..30cc522 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1696,7 +1696,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 static void
 check_sym_interfaces (gfc_symbol *sym)
 {
-  char interface_name[100];
+  char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("generic interface ''")];
   gfc_interface *p;
 
   if (sym->ns != gfc_current_ns)
@@ -1733,7 +1733,7 @@ check_sym_interfaces (gfc_symbol *sym)
 static void
 check_uop_interfaces (gfc_user_op *uop)
 {
-  char interface_name[100];
+  char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
   gfc_user_op *uop2;
   gfc_namespace *ns;
 
@@ -1810,7 +1810,7 @@ void
 gfc_check_interfaces (gfc_namespace *ns)
 {
   gfc_namespace *old_ns, *ns2;
-  char interface_name[100];
+  char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
   int i;
 
   old_ns = gfc_current_ns;
-- 
2.6.2

[PATCH] Use gfc_add_*_component defines where appropriate

[Bernhard Reutner-Fischer]

A couple of places used gfc_add_component_ref(expr, "string") instead of
the defines from gfortran.h

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

        * class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
        instead of gfc_add_component_ref().
        (gfc_get_len_component): Call gfc_add_len_component() instead of
        gfc_add_component_ref().
        * trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
        gfc_add_data_component() instead of gfc_add_component_ref().
        * trans.c (gfc_add_finalizer_call): Call
        gfc_add_final_component() and gfc_add_size_component() instead
        of gfc_add_component_ref.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/class.c           | 4 ++--
 gcc/fortran/trans-intrinsic.c | 2 +-
 gcc/fortran/trans.c           | 4 ++--
 3 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8b49ae9..027cb89 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
   int rank = CLASS_DATA (e)->as->rank;
   gfc_array_spec *as = CLASS_DATA (e)->as;
   gfc_ref *ref = NULL;
-  gfc_add_component_ref (e, "_data");
+  gfc_add_data_component (e);
   e->rank = rank;
   for (ref = e->ref; ref; ref = ref->next)
     if (!ref->next)
@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
       ref = ref->next;
     }
   /* And replace if with a ref to the _len component.  */
-  gfc_add_component_ref (ptr, "_len");
+  gfc_add_len_component (ptr);
   return ptr;
 }
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1dabc26..2ef0709 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
   if (arg_expr->rank == 0)
     {
       if (arg_expr->ts.type == BT_CLASS)
-	gfc_add_component_ref (arg_expr, "_data");
+	gfc_add_data_component (arg_expr);
       gfc_conv_expr_reference (se, arg_expr);
     }
   else
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2a91c35..14dad0f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
 
       final_expr = gfc_copy_expr (expr);
       gfc_add_vptr_component (final_expr);
-      gfc_add_component_ref (final_expr, "_final");
+      gfc_add_final_component (final_expr);
 
       elem_size = gfc_copy_expr (expr);
       gfc_add_vptr_component (elem_size);
-      gfc_add_component_ref (elem_size, "_size");
+      gfc_add_size_component (elem_size);
     }
 
   gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
-- 
2.6.2

[PATCH] Commentary typo fix for gfc_typenode_for_spec()

[Bernhard Reutner-Fischer]

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/trans-types.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 6e2b3f1..0ac337e 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1049,7 +1049,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
   return gfc_get_character_type_len (kind, len);
 }
 \f
-/* Covert a basic type.  This will be an array for character types.  */
+/* Convert a basic type.  This will be an array for character types.  */
 
 tree
 gfc_typenode_for_spec (gfc_typespec * spec)
-- 
2.6.2

[PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

gcc/fortran/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
	* resolve.c: Include spellcheck.h.
	(lookup_function_fuzzy_find_candidates): New static function.
	(lookup_uop_fuzzy_find_candidates): Likewise.
	(lookup_uop_fuzzy): Likewise.
	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
	(gfc_lookup_function_fuzzy): New definition.
	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
	* interface.c (check_interface0): Likewise.
	* symbol.c: Include spellcheck.h.
	(lookup_symbol_fuzzy_find_candidates): New static function.
	(lookup_symbol_fuzzy): Likewise.
	(gfc_set_default_type): Call lookup_symbol_fuzzy.
	(lookup_component_fuzzy_find_candidates): New static function.
	(lookup_component_fuzzy): Likewise.
	(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/spellcheck-operator.f90: New testcase.
	* gfortran.dg/spellcheck-procedure.f90: New testcase.
	* gfortran.dg/spellcheck-structure.f90: New testcase.

---

David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
   likely to be meaningless.  */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

I do not immediately see how to handle subroutines. Ideas?

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/gfortran.h                             |   1 +
 gcc/fortran/interface.c                            |  16 ++-
 gcc/fortran/resolve.c                              | 135 ++++++++++++++++++++-
 gcc/fortran/symbol.c                               | 129 +++++++++++++++++++-
 gcc/testsuite/gfortran.dg/spellcheck-operator.f90  |  30 +++++
 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 |  41 +++++++
 gcc/testsuite/gfortran.dg/spellcheck-structure.f90 |  35 ++++++
 7 files changed, 376 insertions(+), 11 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..cbfd592 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3060,6 +3060,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
 
 
 /* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30cc522..19f800f 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1590,10 +1590,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 	  if (p->sym->attr.external)
 	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
 		       p->sym->name, interface_name, &p->sym->declared_at);
-	  else
-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
-		       "subroutine", p->sym->name, interface_name,
-		      &p->sym->declared_at);
+	  else {
+	    const char *guessed
+	      = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine; did you mean %qs?", p->sym->name,
+			interface_name, &p->sym->declared_at, guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine", p->sym->name, interface_name,
+			&p->sym->declared_at);
+	  }
 	  return 1;
 	}
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..6e1f63c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "data.h"
 #include "target-memory.h" /* for gfc_simplify_transfer */
 #include "constructor.h"
+#include "spellcheck.h"
 
 /* Types used in equivalence statements.  */
 
@@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
   return true;
 }
 
+/* Recursively append candidate SYM to CANDIDATES.  */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+                                       vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  for (p = sym->right; p; p = p->right)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+  for (p = sym->left; p; p = p->left)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+}
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account.  */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+  auto_vec <const char *> candidates;
+  lookup_function_fuzzy_find_candidates (fun, &candidates);
+
+  /* Determine closest match.  */
+  int i;
+  const char *name, *best = NULL;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  FOR_EACH_VEC_ELT (candidates, i, name)
+    {
+      edit_distance_t dist = levenshtein_distance (fn, name);
+      if (dist < best_distance)
+	{
+	  best_distance = dist;
+	  best = name;
+	}
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
+      if (best_distance > cutoff)
+	return NULL;
+    }
+  return best;
+}
+
 
 /* Resolve a procedure call not known to be generic nor specific.  */
 
@@ -2732,8 +2788,15 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
-		     sym->name, &expr->where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &expr->where, guessed);
+	  else
+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
+		       sym->name, &expr->where);
 	  return false;
 	}
       else
@@ -3504,6 +3567,63 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
   return t;
 }
 
+/* Recursively append candidate UOP to CANDIDATES.  */
+
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+				  vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  /* Not sure how to properly filter here.  Use all for a start.
+     n.uop.op is NULL for empty interface operators (is that legal?) disregard
+     these as i suppose they don't make terribly sense.  */
+  for (p = uop->right; p; p = p->right)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.uop->op != NULL)
+	candidates->safe_push (p->name);
+    }
+  for (p = uop->left; p; p = p->left)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.uop->op != NULL)
+	candidates->safe_push (p->name);
+    }
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+  auto_vec <const char *> candidates;
+  lookup_uop_fuzzy_find_candidates (uop, &candidates);
+
+  /* Determine closest match.  */
+  int i;
+  const char *name, *best = NULL;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  FOR_EACH_VEC_ELT (candidates, i, name)
+    {
+      edit_distance_t dist = levenshtein_distance (op, name);
+      if (dist < best_distance)
+	{
+	  best_distance = dist;
+	  best = name;
+	}
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (op), strlen (best)) / 2;
+      if (best_distance > cutoff)
+	return NULL;
+    }
+  return best;
+}
+
 
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
@@ -3703,7 +3823,16 @@ resolve_operator (gfc_expr *e)
 
     case INTRINSIC_USER:
       if (e->value.op.uop->op == NULL)
-	sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+	{
+	  const char *name = e->value.op.uop->name;
+	  const char *guessed;
+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+	  if (guessed)
+	    sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+		name, guessed);
+	  else
+	    sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
 		 e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..212f7d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "parse.h"
 #include "match.h"
 #include "constructor.h"
+#include "spellcheck.h"
 
 
 /* Strings for all symbol attributes.  We use these for dumping the
@@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
 }
 
 
+/* Recursively append candidate SYM to CANDIDATES.  */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+				        vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  for (p = sym->right; p; p = p->right)
+    {
+      lookup_symbol_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+  for (p = sym->left; p; p = p->left)
+    {
+      lookup_symbol_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+}
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account.  */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+  auto_vec <const char *> candidates;
+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+
+  /* Determine closest match.  */
+  int i;
+  const char *name, *best = NULL;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  FOR_EACH_VEC_ELT (candidates, i, name)
+    {
+      edit_distance_t dist = levenshtein_distance (sym, name);
+      if (dist < best_distance)
+	{
+	  best_distance = dist;
+	  best = name;
+	}
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
+      if (best_distance > cutoff)
+	return NULL;
+    }
+  return best;
+}
+
+
 /* Given a pointer to a symbol, set its type according to the first
    letter of its name.  Fails if the letter in question has no default
    type.  */
@@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     {
       if (error_flag && !sym->attr.untyped)
 	{
-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
-		     sym->name, &sym->declared_at);
+	  const char *guessed
+	    = lookup_symbol_fuzzy (sym->name, sym);
+	  if (guessed)
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &sym->declared_at, guessed);
+	  else
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
 
@@ -2188,6 +2252,55 @@ bad:
 }
 
 
+/* Recursively append candidate COMPONENT structures to CANDIDATES.  */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+				        vec<const char *> *candidates)
+{
+  for (gfc_component *p = component; p; p = p->next)
+    {
+      if (00 && p->ts.type == BT_DERIVED)
+	/* ??? There's no (suitable) DERIVED_TYPE which would come in
+	   handy throughout the frontend; Use CLASS_DATA here for brevity.  */
+	lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
+      candidates->safe_push (p->name);
+    }
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+  auto_vec <const char *> candidates;
+  lookup_component_fuzzy_find_candidates (component, &candidates);
+
+  /* Determine closest match.  */
+  int i;
+  const char *name, *best = NULL;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  FOR_EACH_VEC_ELT (candidates, i, name)
+    {
+      edit_distance_t dist = levenshtein_distance (member, name);
+      if (dist < best_distance)
+	{
+	  best_distance = dist;
+	  best = name;
+	}
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (member), strlen (best)) / 2;
+      if (best_distance > cutoff)
+	return NULL;
+    }
+  return best;
+}
+
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
    not found or the components are private.  If noaccess is set, no access
@@ -2238,8 +2351,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
     }
 
   if (p == NULL && !silent)
-    gfc_error ("%qs at %C is not a member of the %qs structure",
-	       name, sym->name);
+    {
+      const char *guessed = lookup_component_fuzzy (name, sym->components);
+      if (guessed)
+	gfc_error ("%qs at %C is not a member of the %qs structure"
+		   "; did you mean %qs?",
+		   name, sym->name, guessed);
+      else
+	gfc_error ("%qs at %C is not a member of the %qs structure",
+		   name, sym->name);
+    }
 
   return p;
 }
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  interface operator (.mywrong.)
+    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+  end interface
+
+  interface operator (.mygood.)
+    module procedure something_good
+  end interface
+
+  integer :: i, j, added
+  i = 0
+  j = 0
+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
new file mode 100644
index 0000000..7923081
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+subroutine bark_unless_zero(iarg)
+  implicit none
+  integer, intent(in) :: iarg
+  if (iarg /= 0) call abort
+end subroutine bark_unless_zero
+
+function myadd(iarg1, iarg2)
+  implicit none
+  integer :: myadd
+  integer, intent(in) :: iarg1, iarg2
+  myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  integer :: i, j, myadd
+  i = 0
+  j = 0
+! I suppose this cannot be made to work, no\\?
+!  call barf_unless_zero(i) ! { -dg-error "; did you mean .bark_unless_zero.\\?" }
+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  j = mya(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  if (j /= 42) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+   real :: radius
+   integer :: i
+end type type1
+
+type type2
+  integer :: myint
+  type(type1) :: mytype
+end type type2
+
+type type3
+  type(type2) :: type_2
+end type type3
+type type4
+  type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end
-- 
2.6.2

Re: [PATCH] Derive interface buffers from max name length

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
> These three function used a hardcoded buffer of 100 but would be better
> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
> name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

Ok for GCC 7 stage1 with these changes. I don't think it's worth
putting it into GCC 6 at this point anymore, unless this is actually
fixing some bugs that are visible to users?

-- 
Janne Blomqvist

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Steve Kargl]

On Tue, Dec 01, 2015 at 01:55:01PM +0100, Bernhard Reutner-Fischer wrote:
> 
> David Malcolm nice Levenshtein distance spelling check helpers
> were used in some parts of other frontends. This proposed patch adds
> some spelling corrections to the fortran frontend.
> 
> Suggestions are printed if we can find a suitable name, currently
> perusing a very simple cutoff factor:
> /* If more than half of the letters were misspelled, the suggestion is
>    likely to be meaningless.  */
> cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
> which effectively skips names with less than 4 characters.
> For e.g. structures, one could try to be much smarter in an attempt to
> also provide suggestions for single-letter members/components.
> 
> This patch covers (at least partly):
> - user-defined operators
> - structures (types and their components)
> - functions
> - symbols (variables)
> 
> I do not immediately see how to handle subroutines. Ideas?
> 
> If anybody has a testcase where a spelling-suggestion would make sense
> then please pass it along so we maybe can add support for GCC-7.
> 

What problem are you trying to solve here?  The patch looks like
unneeded complexity with the result of injecting C++ idioms into
the Fortran FE.

-- 
Steve

Re: [PATCH] Commentary typo fix for gfc_typenode_for_spec()

[Steve Kargl]

On Tue, Dec 01, 2015 at 01:55:00PM +0100, Bernhard Reutner-Fischer wrote:
> Regstrapped without regressions, ok for trunk stage3 now / next stage1?
> 
> gcc/fortran/ChangeLog
> 
> 2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.
> 

Patches to fix typographical errors in comments are pre-approved.

-- 
Steve

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

On 1 December 2015 at 16:01, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Tue, Dec 01, 2015 at 01:55:01PM +0100, Bernhard Reutner-Fischer wrote:
>>
>> David Malcolm nice Levenshtein distance spelling check helpers
>> were used in some parts of other frontends. This proposed patch adds
>> some spelling corrections to the fortran frontend.

> What problem are you trying to solve here?  The patch looks like

The idea is to improve the programmer experience when writing code.
See the testcases enclosed in the patch. I consider this a feature :)

> unneeded complexity with the result of injecting C++ idioms into
> the Fortran FE.

What C++ idioms are you referring to? The autovec?
AFAIU the light use of C++ in GCC is deemed OK. I see usage of
std::swap and std::map in the FE, not to mention the wide-int uses
(wi::). Thus we don't have to realloc/strcat but can use vectors to
the same effect, just as other frontends, including the C frontend,
do.
I take it you remember that we had to change all "try" to something
C++ friendly. If the Fortran FE meant to opt-out of being compiled
with a C++ compiler in the first place, why were all the C++ clashes
rewritten, back then? :)

thanks,

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Steve Kargl]

On Tue, Dec 01, 2015 at 05:12:57PM +0100, Bernhard Reutner-Fischer wrote:
> On 1 December 2015 at 16:01, Steve Kargl
> <sgk@troutmask.apl.washington.edu> wrote:
> > On Tue, Dec 01, 2015 at 01:55:01PM +0100, Bernhard Reutner-Fischer wrote:
> >>
> >> David Malcolm nice Levenshtein distance spelling check helpers
> >> were used in some parts of other frontends. This proposed patch adds
> >> some spelling corrections to the fortran frontend.
> 
> > What problem are you trying to solve here?  The patch looks like
> 
> The idea is to improve the programmer experience when writing code.
> See the testcases enclosed in the patch. I consider this a feature :)

Opinions differ.  I consider it unnecessary bloat.

> > unneeded complexity with the result of injecting C++ idioms into
> > the Fortran FE.
> 
> What C++ idioms are you referring to? The autovec?
> AFAIU the light use of C++ in GCC is deemed OK. I see usage of
> std::swap and std::map in the FE, not to mention the wide-int uses
> (wi::). Thus we don't have to realloc/strcat but can use vectors to
> the same effect, just as other frontends, including the C frontend,
> do.
> I take it you remember that we had to change all "try" to something
> C++ friendly. If the Fortran FE meant to opt-out of being compiled
> with a C++ compiler in the first place, why were all the C++ clashes
> rewritten, back then? :)

Yes, I know there are other C++ (mis)features within the
Fortran FE especially in the trans-*.c files.  Those are
accepted (by some) as necessary evils to interface with 
the ME.  Your patch injects C++ into otherwise perfectly
fine C code, which makes it more difficult for those with
no or very limited C++ knowledge to maintain the gfortran.

There are currently 806 open bug reports for gfortran.
AFAIK, your patch does not address any of those bug reports.
The continued push to inject C++ into the Fortran FE will
have the (un)intentional consequence of forcing at least one
active gfortran contributor to stop.

--  
Steve

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On 1 December 2015 at 15:52, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
> On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
> <rep.dot.nop@gmail.com> wrote:
>> These three function used a hardcoded buffer of 100 but would be better
>> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
>> name in any of our supported standards (63 as of f2003 ff.).
>
> Please use xasprintf() instead (and free the result, or course). One
> of my backburner projects is to get rid of these static symbol
> buffers, and use dynamic buffers (or the symbol table) instead. We
> IIRC already have some ugly hacks by using hashing to get around
> GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
> make the situation worse per se, but if you're going to fix it, lets
> do it properly.

I see.

/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
32

What about memory fragmentation when switching to heap-based allocation?
Or is there consensus that these are in the noise compared to other
parts of the compiler?

BTW:
$ git grep APO
io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };


> Ok for GCC 7 stage1 with these changes. I don't think it's worth
> putting it into GCC 6 at this point anymore, unless this is actually
> fixing some bugs that are visible to users?

Not visible, no, can wait easily.

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[David Malcolm]

On Tue, 2015-12-01 at 13:55 +0100, Bernhard Reutner-Fischer wrote:
> gcc/fortran/ChangeLog
> 
> 2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
> 	* resolve.c: Include spellcheck.h.
> 	(lookup_function_fuzzy_find_candidates): New static function.
> 	(lookup_uop_fuzzy_find_candidates): Likewise.
> 	(lookup_uop_fuzzy): Likewise.
> 	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
> 	(gfc_lookup_function_fuzzy): New definition.
> 	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
> 	* interface.c (check_interface0): Likewise.
> 	* symbol.c: Include spellcheck.h.
> 	(lookup_symbol_fuzzy_find_candidates): New static function.
> 	(lookup_symbol_fuzzy): Likewise.
> 	(gfc_set_default_type): Call lookup_symbol_fuzzy.
> 	(lookup_component_fuzzy_find_candidates): New static function.
> 	(lookup_component_fuzzy): Likewise.
> 	(gfc_find_component): Call lookup_component_fuzzy.
> 
> gcc/testsuite/ChangeLog
> 
> 2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* gfortran.dg/spellcheck-operator.f90: New testcase.
> 	* gfortran.dg/spellcheck-procedure.f90: New testcase.
> 	* gfortran.dg/spellcheck-structure.f90: New testcase.
> 
> ---
> 
> David Malcolm nice Levenshtein distance spelling check helpers
> were used in some parts of other frontends. This proposed patch adds
> some spelling corrections to the fortran frontend.
> 
> Suggestions are printed if we can find a suitable name, currently
> perusing a very simple cutoff factor:
> /* If more than half of the letters were misspelled, the suggestion is
>    likely to be meaningless.  */
> cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
> which effectively skips names with less than 4 characters.
> For e.g. structures, one could try to be much smarter in an attempt to
> also provide suggestions for single-letter members/components.
> 
> This patch covers (at least partly):
> - user-defined operators
> - structures (types and their components)
> - functions
> - symbols (variables)
> 
> I do not immediately see how to handle subroutines. Ideas?
> 
> If anybody has a testcase where a spelling-suggestion would make sense
> then please pass it along so we maybe can add support for GCC-7.
> 
> Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
> ---
>  gcc/fortran/gfortran.h                             |   1 +
>  gcc/fortran/interface.c                            |  16 ++-
>  gcc/fortran/resolve.c                              | 135 ++++++++++++++++++++-
>  gcc/fortran/symbol.c                               | 129 +++++++++++++++++++-
>  gcc/testsuite/gfortran.dg/spellcheck-operator.f90  |  30 +++++
>  gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 |  41 +++++++
>  gcc/testsuite/gfortran.dg/spellcheck-structure.f90 |  35 ++++++
>  7 files changed, 376 insertions(+), 11 deletions(-)
>  create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
>  create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
>  create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90
> 
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 5487c93..cbfd592 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -3060,6 +3060,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
>  bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
>  bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
>  extern int gfc_do_concurrent_flag;
> +const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
>  
> 
>  /* array.c */
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 30cc522..19f800f 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1590,10 +1590,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
>  	  if (p->sym->attr.external)
>  	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
>  		       p->sym->name, interface_name, &p->sym->declared_at);
> -	  else
> -	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
> -		       "subroutine", p->sym->name, interface_name,
> -		      &p->sym->declared_at);
> +	  else {
> +	    const char *guessed
> +	      = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
> +	    if (guessed)
> +	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
> +			 "subroutine; did you mean %qs?", p->sym->name,
> +			interface_name, &p->sym->declared_at, guessed);
> +	    else
> +	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
> +			 "subroutine", p->sym->name, interface_name,
> +			&p->sym->declared_at);
> +	  }
>  	  return 1;
>  	}
>  
> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 685e3f5..6e1f63c 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3.  If not see
>  #include "data.h"
>  #include "target-memory.h" /* for gfc_simplify_transfer */
>  #include "constructor.h"
> +#include "spellcheck.h"
>  
>  /* Types used in equivalence statements.  */
>  
> @@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
>    return true;
>  }
>  
> +/* Recursively append candidate SYM to CANDIDATES.  */
> +
> +static void
> +lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
> +                                       vec<const char *> *candidates)
> +{
> +  gfc_symtree *p;
> +  for (p = sym->right; p; p = p->right)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +  for (p = sym->left; p; p = p->left)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +}
> +
> +
> +/* Lookup function FN fuzzily, taking names in FUN into account.  */
> +
> +const char*
> +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_function_fuzzy_find_candidates (fun, &candidates);
> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  FOR_EACH_VEC_ELT (candidates, i, name)
> +    {
> +      edit_distance_t dist = levenshtein_distance (fn, name);
> +      if (dist < best_distance)
> +	{
> +	  best_distance = dist;
> +	  best = name;
> +	}
> +    }
> +  /* If more than half of the letters were misspelled, the suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
> +      if (best_distance > cutoff)
> +	return NULL;
> +    }
> +  return best;
> +}


Caveat: I'm not very familiar with the Fortran FE, so take the following
with a pinch of salt.

If I'm reading things right, here, and in various other places, you're
building a vec of const char *, and then seeing which one of those
candidates is the best match for another const char *.

You could simplify things by adding a helper function to spellcheck.h,
akin to this one:

extern tree
find_closest_identifier (tree target, const auto_vec<tree> *candidates);

This would reduce the amount of duplication in the patch (and slightly
reduce the amount of C++).

[are there IDENTIFIER nodes in the Fortran FE, or is it all const char
*? this would avoid some strlen calls]
 
>  /* Resolve a procedure call not known to be generic nor specific.  */
>  
> @@ -2732,8 +2788,15 @@ set_type:
>  
>        if (ts->type == BT_UNKNOWN)
>  	{
> -	  gfc_error ("Function %qs at %L has no IMPLICIT type",
> -		     sym->name, &expr->where);
> +	  const char *guessed
> +	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
> +	  if (guessed)
> +	    gfc_error ("Function %qs at %L has no IMPLICIT type"
> +		       "; did you mean %qs?",
> +		       sym->name, &expr->where, guessed);
> +	  else
> +	    gfc_error ("Function %qs at %L has no IMPLICIT type",
> +		       sym->name, &expr->where);
>  	  return false;
>  	}
>        else
> @@ -3504,6 +3567,63 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
>    return t;
>  }
>  
> +/* Recursively append candidate UOP to CANDIDATES.  */
> +
> +static void
> +lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
> +				  vec<const char *> *candidates)
> +{
> +  gfc_symtree *p;
> +  /* Not sure how to properly filter here.  Use all for a start.
> +     n.uop.op is NULL for empty interface operators (is that legal?) disregard
> +     these as i suppose they don't make terribly sense.  */
> +  for (p = uop->right; p; p = p->right)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.uop->op != NULL)
> +	candidates->safe_push (p->name);
> +    }
> +  for (p = uop->left; p; p = p->left)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.uop->op != NULL)
> +	candidates->safe_push (p->name);
> +    }
> +}
> +
> +/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
> +
> +static const char*
> +lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_uop_fuzzy_find_candidates (uop, &candidates);
> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  FOR_EACH_VEC_ELT (candidates, i, name)
> +    {
> +      edit_distance_t dist = levenshtein_distance (op, name);
> +      if (dist < best_distance)
> +	{
> +	  best_distance = dist;
> +	  best = name;
> +	}
> +    }
> +  /* If more than half of the letters were misspelled, the suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (op), strlen (best)) / 2;
> +      if (best_distance > cutoff)
> +	return NULL;
> +    }
> +  return best;
> +}

Here again, I think.


>  /* Resolve an operator expression node.  This can involve replacing the
>     operation with a user defined function call.  */
> @@ -3703,7 +3823,16 @@ resolve_operator (gfc_expr *e)
>  
>      case INTRINSIC_USER:
>        if (e->value.op.uop->op == NULL)
> -	sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
> +	{
> +	  const char *name = e->value.op.uop->name;
> +	  const char *guessed;
> +	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
> +	  if (guessed)
> +	    sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
> +		name, guessed);
> +	  else
> +	    sprintf (msg, _("Unknown operator '%s' at %%L"), name);
> +	}
>        else if (op2 == NULL)
>  	sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
>  		 e->value.op.uop->name, gfc_typename (&op1->ts));
> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> index ff9aff9..212f7d8 100644
> --- a/gcc/fortran/symbol.c
> +++ b/gcc/fortran/symbol.c
> @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
>  #include "parse.h"
>  #include "match.h"
>  #include "constructor.h"
> +#include "spellcheck.h"
>  
> 
>  /* Strings for all symbol attributes.  We use these for dumping the
> @@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
>  }
>  
> 
> +/* Recursively append candidate SYM to CANDIDATES.  */
> +
> +static void
> +lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
> +				        vec<const char *> *candidates)
> +{
> +  gfc_symtree *p;
> +  for (p = sym->right; p; p = p->right)
> +    {
> +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +  for (p = sym->left; p; p = p->left)
> +    {
> +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +}
> +
> +
> +/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account.  */
> +
> +static const char*
> +lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  FOR_EACH_VEC_ELT (candidates, i, name)
> +    {
> +      edit_distance_t dist = levenshtein_distance (sym, name);
> +      if (dist < best_distance)
> +	{
> +	  best_distance = dist;
> +	  best = name;
> +	}
> +    }
> +  /* If more than half of the letters were misspelled, the suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
> +      if (best_distance > cutoff)
> +	return NULL;
> +    }
> +  return best;
> +}

Here again, I think.

> +
>  /* Given a pointer to a symbol, set its type according to the first
>     letter of its name.  Fails if the letter in question has no default
>     type.  */
> @@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
>      {
>        if (error_flag && !sym->attr.untyped)
>  	{
> -	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> -		     sym->name, &sym->declared_at);
> +	  const char *guessed
> +	    = lookup_symbol_fuzzy (sym->name, sym);
> +	  if (guessed)
> +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
> +		       "; did you mean %qs?",
> +		       sym->name, &sym->declared_at, guessed);
> +	  else
> +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> +		       sym->name, &sym->declared_at);
>  	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
>  	}
>  
> @@ -2188,6 +2252,55 @@ bad:
>  }
>  
> 
> +/* Recursively append candidate COMPONENT structures to CANDIDATES.  */
> +
> +static void
> +lookup_component_fuzzy_find_candidates (gfc_component *component,
> +				        vec<const char *> *candidates)
> +{
> +  for (gfc_component *p = component; p; p = p->next)
> +    {
> +      if (00 && p->ts.type == BT_DERIVED)
> +	/* ??? There's no (suitable) DERIVED_TYPE which would come in
> +	   handy throughout the frontend; Use CLASS_DATA here for brevity.  */
> +	lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
> +      candidates->safe_push (p->name);
> +    }
> +}
> +
> +/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
> +
> +static const char*
> +lookup_component_fuzzy (const char *member, gfc_component *component)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_component_fuzzy_find_candidates (component, &candidates);
> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  FOR_EACH_VEC_ELT (candidates, i, name)
> +    {
> +      edit_distance_t dist = levenshtein_distance (member, name);
> +      if (dist < best_distance)
> +	{
> +	  best_distance = dist;
> +	  best = name;
> +	}
> +    }
> +  /* If more than half of the letters were misspelled, the suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (member), strlen (best)) / 2;
> +      if (best_distance > cutoff)
> +	return NULL;
> +    }
> +  return best;
> +}

...and here again.

>  /* Given a derived type node and a component name, try to locate the
>     component structure.  Returns the NULL pointer if the component is
>     not found or the components are private.  If noaccess is set, no access
> @@ -2238,8 +2351,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
>      }
>  
>    if (p == NULL && !silent)
> -    gfc_error ("%qs at %C is not a member of the %qs structure",
> -	       name, sym->name);
> +    {
> +      const char *guessed = lookup_component_fuzzy (name, sym->components);
> +      if (guessed)
> +	gfc_error ("%qs at %C is not a member of the %qs structure"
> +		   "; did you mean %qs?",
> +		   name, sym->name, guessed);
> +      else
> +	gfc_error ("%qs at %C is not a member of the %qs structure",
> +		   name, sym->name);
> +    }
>  
>    return p;
>  }
> diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
> new file mode 100644
> index 0000000..810a770
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
> @@ -0,0 +1,30 @@
> +! { dg-do compile }
> +! test levenshtein based spelling suggestions
> +
> +module mymod1
> +  implicit none
> +  contains
> +    function something_good (iarg1)
> +      integer :: something_good
> +      integer, intent(in) :: iarg1
> +      something_good = iarg1 + 42
> +    end function something_good
> +end module mymod1
> +
> +program spellchekc
> +  use mymod1
> +  implicit none
> +
> +  interface operator (.mywrong.)
> +    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
> +  end interface
> +
> +  interface operator (.mygood.)
> +    module procedure something_good
> +  end interface
> +
> +  integer :: i, j, added
> +  i = 0
> +  j = 0
> +  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
> +end program spellchekc
> diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
> new file mode 100644
> index 0000000..7923081
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
> @@ -0,0 +1,41 @@
> +! { dg-do compile }
> +! test levenshtein based spelling suggestions
> +
> +module mymod1
> +  implicit none
> +  contains
> +    function something_good (iarg1)
> +      integer :: something_good
> +      integer, intent(in) :: iarg1
> +      something_good = iarg1 + 42
> +    end function something_good
> +end module mymod1
> +
> +subroutine bark_unless_zero(iarg)
> +  implicit none
> +  integer, intent(in) :: iarg
> +  if (iarg /= 0) call abort
> +end subroutine bark_unless_zero
> +
> +function myadd(iarg1, iarg2)
> +  implicit none
> +  integer :: myadd
> +  integer, intent(in) :: iarg1, iarg2
> +  myadd = iarg1 + iarg2
> +end function myadd
> +
> +program spellchekc
> +  use mymod1
> +  implicit none
> +
> +  integer :: i, j, myadd
> +  i = 0
> +  j = 0
> +! I suppose this cannot be made to work, no\\?
> +!  call barf_unless_zero(i) ! { -dg-error "; did you mean .bark_unless_zero.\\?" }
> +  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
> +  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
> +  j = mya(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
> +  if (j /= 42) call abort
> +
> +end program spellchekc
> diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
> new file mode 100644
> index 0000000..929e05f
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
> @@ -0,0 +1,35 @@
> +! { dg-do compile }
> +! test levenshtein based spelling suggestions
> +implicit none
> +
> +!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
> +type type1
> +   real :: radius
> +   integer :: i
> +end type type1
> +
> +type type2
> +  integer :: myint
> +  type(type1) :: mytype
> +end type type2
> +
> +type type3
> +  type(type2) :: type_2
> +end type type3
> +type type4
> +  type(type3) :: type_3
> +end type type4
> +
> +type(type1) :: t1
> +t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
> +t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
> +type(type2) :: t2
> +t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
> +t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
> +type(type4) :: t4
> +t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
> +
> +!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
> +integer :: iarg1
> +iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
> +end

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

On 1 December 2015 at 17:41, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Tue, Dec 01, 2015 at 05:12:57PM +0100, Bernhard Reutner-Fischer wrote:
>> On 1 December 2015 at 16:01, Steve Kargl
>> <sgk@troutmask.apl.washington.edu> wrote:
>> > On Tue, Dec 01, 2015 at 01:55:01PM +0100, Bernhard Reutner-Fischer wrote:
>> >>
>> >> David Malcolm nice Levenshtein distance spelling check helpers
>> >> were used in some parts of other frontends. This proposed patch adds
>> >> some spelling corrections to the fortran frontend.
>>
>> > What problem are you trying to solve here?  The patch looks like
>>
>> The idea is to improve the programmer experience when writing code.
>> See the testcases enclosed in the patch. I consider this a feature :)
>
> Opinions differ.  I consider it unnecessary bloat.

Fair enough.
I fully agree that it's bloat.

The compiler is so tremendously bloated by now anyway that i consider
these couple of kilobyte to have a nice bloat/user friendliness
factor, overall ;)
I can imagine that people code their fortran programs in an IDE (the
bloated variant of an editor, mine is ~20518 bytes of text, no data,
no bss) and IDEs will sooner or later support fixit-hints. Even the
console/terminal users might enjoy to safe them a cycle of opening a
different file, looking up the type/module/etc name and then going
back to the source-file to correct their typo. *I* would welcome that
sometimes for sure :)

>> > unneeded complexity with the result of injecting C++ idioms into
>> > the Fortran FE.
>>
>> What C++ idioms are you referring to? The autovec?
>> AFAIU the light use of C++ in GCC is deemed OK. I see usage of
>> std::swap and std::map in the FE, not to mention the wide-int uses
>> (wi::). Thus we don't have to realloc/strcat but can use vectors to
>> the same effect, just as other frontends, including the C frontend,
>> do.
>> I take it you remember that we had to change all "try" to something
>> C++ friendly. If the Fortran FE meant to opt-out of being compiled
>> with a C++ compiler in the first place, why were all the C++ clashes
>> rewritten, back then? :)
>
> Yes, I know there are other C++ (mis)features within the
> Fortran FE especially in the trans-*.c files.  Those are
> accepted (by some) as necessary evils to interface with
> the ME.  Your patch injects C++ into otherwise perfectly
> fine C code, which makes it more difficult for those with
> no or very limited C++ knowledge to maintain the gfortran.

So you're in favour of using realloc and strcat, ok. I can use that.
Let me see if ipa-icf can replace all the identical tails of the
lookup_*_fuzzy into a common helper.
Shouldn't rely on LTO anyway nor ipa-icf i suppose.

>
> There are currently 806 open bug reports for gfortran.
> AFAIK, your patch does not address any of those bug reports.

I admit i didn't look..

> The continued push to inject C++ into the Fortran FE will
> have the (un)intentional consequence of forcing at least one
> active gfortran contributor to stop.

That was not my intention for sure.

cheers,

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

On 1 December 2015 at 18:28, David Malcolm <dmalcolm@redhat.com> wrote:
> On Tue, 2015-12-01 at 13:55 +0100, Bernhard Reutner-Fischer wrote:


>> +/* Lookup function FN fuzzily, taking names in FUN into account.  */
>> +
>> +const char*
>> +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
>> +{
>> +  auto_vec <const char *> candidates;
>> +  lookup_function_fuzzy_find_candidates (fun, &candidates);
>> +
>> +  /* Determine closest match.  */
>> +  int i;
>> +  const char *name, *best = NULL;
>> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
>> +
>> +  FOR_EACH_VEC_ELT (candidates, i, name)
>> +    {
>> +      edit_distance_t dist = levenshtein_distance (fn, name);
>> +      if (dist < best_distance)
>> +     {
>> +       best_distance = dist;
>> +       best = name;
>> +     }
>> +    }
>> +  /* If more than half of the letters were misspelled, the suggestion is
>> +     likely to be meaningless.  */
>> +  if (best)
>> +    {
>> +      unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
>> +      if (best_distance > cutoff)
>> +     return NULL;
>> +    }
>> +  return best;
>> +}
>
>
> Caveat: I'm not very familiar with the Fortran FE, so take the following
> with a pinch of salt.
>
> If I'm reading things right, here, and in various other places, you're
> building a vec of const char *, and then seeing which one of those
> candidates is the best match for another const char *.
>
> You could simplify things by adding a helper function to spellcheck.h,
> akin to this one:
>
> extern tree
> find_closest_identifier (tree target, const auto_vec<tree> *candidates);

I was hoping for ipa-icf to fix that up on my behalf. I'll try to see
if it does. Short of that: yes, should do that.

>
> This would reduce the amount of duplication in the patch (and slightly
> reduce the amount of C++).

As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)
>
> [are there IDENTIFIER nodes in the Fortran FE, or is it all const char
> *? this would avoid some strlen calls]

Right, but in the Fortran FE these are const char*.

thanks for your comments!

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[David Malcolm]

On Tue, 2015-12-01 at 18:51 +0100, Bernhard Reutner-Fischer wrote:
> On 1 December 2015 at 18:28, David Malcolm <dmalcolm@redhat.com> wrote:
> > On Tue, 2015-12-01 at 13:55 +0100, Bernhard Reutner-Fischer wrote:
> 
> 
> >> +/* Lookup function FN fuzzily, taking names in FUN into account.  */
> >> +
> >> +const char*
> >> +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
> >> +{
> >> +  auto_vec <const char *> candidates;
> >> +  lookup_function_fuzzy_find_candidates (fun, &candidates);
> >> +
> >> +  /* Determine closest match.  */
> >> +  int i;
> >> +  const char *name, *best = NULL;
> >> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> >> +
> >> +  FOR_EACH_VEC_ELT (candidates, i, name)
> >> +    {
> >> +      edit_distance_t dist = levenshtein_distance (fn, name);
> >> +      if (dist < best_distance)
> >> +     {
> >> +       best_distance = dist;
> >> +       best = name;
> >> +     }
> >> +    }
> >> +  /* If more than half of the letters were misspelled, the suggestion is
> >> +     likely to be meaningless.  */
> >> +  if (best)
> >> +    {
> >> +      unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
> >> +      if (best_distance > cutoff)
> >> +     return NULL;
> >> +    }
> >> +  return best;
> >> +}
> >
> >
> > Caveat: I'm not very familiar with the Fortran FE, so take the following
> > with a pinch of salt.
> >
> > If I'm reading things right, here, and in various other places, you're
> > building a vec of const char *, and then seeing which one of those
> > candidates is the best match for another const char *.
> >
> > You could simplify things by adding a helper function to spellcheck.h,
> > akin to this one:
> >
> > extern tree
> > find_closest_identifier (tree target, const auto_vec<tree> *candidates);
> 
> I was hoping for ipa-icf to fix that up on my behalf. I'll try to see
> if it does. Short of that: yes, should do that.

I was more thinking about code readability; don't rely on ipa-icf - fix
it in the source.

> > This would reduce the amount of duplication in the patch (and slightly
> > reduce the amount of C++).
> 
> As said, we could as well use a list of candidates with NULL as record marker.
> Implementation cosmetics. Steve seems to not be thrilled by the
> overall idea in the first place, so unless there is clear support by
> somebody else i won't pursue this any further, it's not that i'm bored
> or ran out of stuff i should do.. ;)

(FWIW I liked the idea, but I'm not a Fortran person so my opinion
counts much less that Steve's)

> > [are there IDENTIFIER nodes in the Fortran FE, or is it all const char
> > *? this would avoid some strlen calls]
> 
> Right, but in the Fortran FE these are const char*.
> 
> thanks for your comments!

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Steve Kargl]

On Tue, Dec 01, 2015 at 06:34:57PM +0100, Bernhard Reutner-Fischer wrote:
> On 1 December 2015 at 17:41, Steve Kargl
> >
> > Yes, I know there are other C++ (mis)features within the
> > Fortran FE especially in the trans-*.c files.  Those are
> > accepted (by some) as necessary evils to interface with
> > the ME.  Your patch injects C++ into otherwise perfectly
> > fine C code, which makes it more difficult for those with
> > no or very limited C++ knowledge to maintain the gfortran.
> 
> So you're in favour of using realloc and strcat, ok. I can use that.
> Let me see if ipa-icf can replace all the identical tails of the
> lookup_*_fuzzy into a common helper.
> Shouldn't rely on LTO anyway nor ipa-icf i suppose.

Yes, I would prefer it, but certainly won't demand it.
There are other Fortran contributors/maintainers.  They
may prefer you approach, so give them time to speak up.

-- 
Steve

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Steve Kargl]

On Tue, Dec 01, 2015 at 12:58:28PM -0500, David Malcolm wrote:
> On Tue, 2015-12-01 at 18:51 +0100, Bernhard Reutner-Fischer wrote:
> > As said, we could as well use a list of candidates with NULL as record marker.
> > Implementation cosmetics. Steve seems to not be thrilled by the
> > overall idea in the first place, so unless there is clear support by
> > somebody else i won't pursue this any further, it's not that i'm bored
> > or ran out of stuff i should do.. ;)
> 
> (FWIW I liked the idea, but I'm not a Fortran person so my opinion
> counts much less that Steve's)
> 

Your opinion is as valid as mine.

My only concern is code maintenance.  Injection of C++ (or any
other language) into C code seems to add possible complications
when something needs to be fix or changed to accommodate a new
Fortran freature.

-- 
Steve

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
> As said, we could as well use a list of candidates with NULL as record marker.
> Implementation cosmetics. Steve seems to not be thrilled by the
> overall idea in the first place, so unless there is clear support by
> somebody else i won't pursue this any further, it's not that i'm bored
> or ran out of stuff i should do.. ;)

FWIW, I think the idea of this patch is quite nice, and I'd like to
see it in the compiler.

I'm personally Ok with "C++-isms", but nowadays my contributions are
so minor that my opinion shouldn't carry that much weight on this
matter.


-- 
Janne Blomqvist

Re: [PATCH] Derive interface buffers from max name length

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
> On 1 December 2015 at 15:52, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>> On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
>> <rep.dot.nop@gmail.com> wrote:
>>> These three function used a hardcoded buffer of 100 but would be better
>>> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
>>> name in any of our supported standards (63 as of f2003 ff.).
>>
>> Please use xasprintf() instead (and free the result, or course). One
>> of my backburner projects is to get rid of these static symbol
>> buffers, and use dynamic buffers (or the symbol table) instead. We
>> IIRC already have some ugly hacks by using hashing to get around
>> GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
>> make the situation worse per se, but if you're going to fix it, lets
>> do it properly.
>
> I see.
>
> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
> "^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
> 142
> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
> 32

Yes, that's why it's on the TODO-list rather than on the DONE-list. :)

> What about memory fragmentation when switching to heap-based allocation?
> Or is there consensus that these are in the noise compared to other
> parts of the compiler?

Heap fragmentation is an issue, yes. I'm not sure it's that
performance-critical, but I don't think there is any consensus. I just
want to avoid ugly hacks like symbol hashing to fit within some fixed
buffer. Perhaps an good compromise would be something like std::string
with small string optimization, but as you have seen there is some
resistance to C++. But this is more relevant for mangled symbols, so
GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
few of them left. So, well, if you're sure that mangled symbols are
never copied into the buffers your patch modifies, please consider
your original patch Ok as well. Whichever you prefer.

Performance-wise I think a bigger benefit would be to use the symbol
table more and then e.g. be able to do pointer comparisons rather than
strcmp(). But that is certainly much more work.

> BTW:
> $ git grep APO
> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };

? What are you saying?



-- 
Janne Blomqvist

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Mikael Morin]

Le 03/12/2015 10:29, Janne Blomqvist a écrit :
> On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer
> <rep.dot.nop@gmail.com> wrote:
>> As said, we could as well use a list of candidates with NULL as record marker.
>> Implementation cosmetics. Steve seems to not be thrilled by the
>> overall idea in the first place, so unless there is clear support by
>> somebody else i won't pursue this any further, it's not that i'm bored
>> or ran out of stuff i should do.. ;)
>
> FWIW, I think the idea of this patch is quite nice, and I'd like to
> see it in the compiler.
>
I like this feature as well.

> I'm personally Ok with "C++-isms", but nowadays my contributions are
> so minor that my opinion shouldn't carry that much weight on this
> matter.
>
Same here.
David Malcolm suggested to move the candidate selection code to the 
common middle-end infrastructure, which would move half of the so-called 
"bloat" there.  Steve, would that work for you?

It seems to me that the remaining C++-isms are rather acceptable.
I do agree that the vec implementation details seem overly complex for 
something whose job is just the memory management of a growing (or 
shrinking) vector.  However, the API is consistent and self-explanatory, 
and the usage of it that is made here (just a few "safe_push") is not 
more complex than what would be done with a C-only API.

Mikael

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Steve Kargl]

On Thu, Dec 03, 2015 at 02:53:06PM +0100, Mikael Morin wrote:
> Le 03/12/2015 10:29, Janne Blomqvist a écrit :
> > On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer
> > <rep.dot.nop@gmail.com> wrote:
> >> As said, we could as well use a list of candidates with NULL as record marker.
> >> Implementation cosmetics. Steve seems to not be thrilled by the
> >> overall idea in the first place, so unless there is clear support by
> >> somebody else i won't pursue this any further, it's not that i'm bored
> >> or ran out of stuff i should do.. ;)
> >
> > FWIW, I think the idea of this patch is quite nice, and I'd like to
> > see it in the compiler.
> >
> I like this feature as well.
> 
> > I'm personally Ok with "C++-isms", but nowadays my contributions are
> > so minor that my opinion shouldn't carry that much weight on this
> > matter.
> >
> Same here.
> David Malcolm suggested to move the candidate selection code to the 
> common middle-end infrastructure, which would move half of the so-called 
> "bloat" there.  Steve, would that work for you?

Fine with me.

When debugging, if I run into C++isms, I'll stop and move to
a new bug.  We certainly have enough open bugs to choose from. 

-- 
Steve

Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Mikael Morin]

Hello,

to get things moving again, a few comments on top of David Malcolm's:

Le 01/12/2015 13:55, Bernhard Reutner-Fischer a écrit :
>
> David Malcolm nice Levenshtein distance spelling check helpers
> were used in some parts of other frontends. This proposed patch adds
> some spelling corrections to the fortran frontend.
>
> Suggestions are printed if we can find a suitable name, currently
> perusing a very simple cutoff factor:
> /* If more than half of the letters were misspelled, the suggestion is
>     likely to be meaningless.  */
> cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
> which effectively skips names with less than 4 characters.
> For e.g. structures, one could try to be much smarter in an attempt to
> also provide suggestions for single-letter members/components.
>
> This patch covers (at least partly):
> - user-defined operators
> - structures (types and their components)
> - functions
> - symbols (variables)
>
> I do not immediately see how to handle subroutines. Ideas?
>
Not sure what you are looking for; I can get an error generated in 
gfc_procedure_use if using IMPLICIT NONE (EXTERNAL)

> If anybody has a testcase where a spelling-suggestion would make sense
> then please pass it along so we maybe can add support for GCC-7.
>


> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 685e3f5..6e1f63c 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3.  If not see
>   #include "data.h"
>   #include "target-memory.h" /* for gfc_simplify_transfer */
>   #include "constructor.h"
> +#include "spellcheck.h"
>
>   /* Types used in equivalence statements.  */
>
> @@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
>     return true;
>   }
>
> +/* Recursively append candidate SYM to CANDIDATES.  */
> +
> +static void
> +lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
> +                                       vec<const char *> *candidates)
> +{
> +  gfc_symtree *p;
> +  for (p = sym->right; p; p = p->right)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +  for (p = sym->left; p; p = p->left)
> +    {
> +      lookup_function_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +}

It seems you are considering some candidates more than once here.
The first time through the recursive call you will consider say 
sym->right->right, and with the loop, you'll consider it again after 
returning from the recursive call.
The usual way to traverse the whole tree is to handle the current 
pointer and recurse on left and right pointers.  So without loop.
There is gfc_traverse_ns that you might find handy to do that (no 
obligation).

Same goes for the user operators below.

> +
> +
> +/* Lookup function FN fuzzily, taking names in FUN into account.  */
> +
> +const char*
> +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_function_fuzzy_find_candidates (fun, &candidates);

You have to start the lookup with the current namespace's sym_root (not 
with fun), otherwise you'll miss some candidates.
You may also want to query parent namespaces for host-associated symbols.

> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +

[...]

> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> index ff9aff9..212f7d8 100644
> --- a/gcc/fortran/symbol.c
> +++ b/gcc/fortran/symbol.c
> @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
>   #include "parse.h"
>   #include "match.h"
>   #include "constructor.h"
> +#include "spellcheck.h"
>
>
>   /* Strings for all symbol attributes.  We use these for dumping the
> @@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
>   }
>
>
> +/* Recursively append candidate SYM to CANDIDATES.  */
> +
> +static void
> +lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
> +				        vec<const char *> *candidates)
> +{
> +  gfc_symtree *p;
> +  for (p = sym->right; p; p = p->right)
> +    {
> +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +  for (p = sym->left; p; p = p->left)
> +    {
> +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> +      if (p->n.sym->ts.type != BT_UNKNOWN)
> +	candidates->safe_push (p->name);
> +    }
> +}
This looks like the same as lookup_function_fuzzy_find_candidates, isn't it?
Maybe have a general symbol traversal function with a selection callback 
argument to test whether the symbol is what you want, depending on the 
context (is it a function? a subroutine? etc).

> +
> +
> +/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account.  */
> +
> +static const char*
> +lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
> +{
> +  auto_vec <const char *> candidates;
> +  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
> +
> +  /* Determine closest match.  */
> +  int i;
> +  const char *name, *best = NULL;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  FOR_EACH_VEC_ELT (candidates, i, name)
> +    {
> +      edit_distance_t dist = levenshtein_distance (sym, name);
> +      if (dist < best_distance)
> +	{
> +	  best_distance = dist;
> +	  best = name;
> +	}
> +    }
> +  /* If more than half of the letters were misspelled, the suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
> +      if (best_distance > cutoff)
> +	return NULL;
> +    }
> +  return best;
> +}
> +
> +
>   /* Given a pointer to a symbol, set its type according to the first
>      letter of its name.  Fails if the letter in question has no default
>      type.  */
> @@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
>       {
>         if (error_flag && !sym->attr.untyped)
>   	{
> -	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> -		     sym->name, &sym->declared_at);
> +	  const char *guessed
> +	    = lookup_symbol_fuzzy (sym->name, sym);
> +	  if (guessed)
> +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
> +		       "; did you mean %qs?",
> +		       sym->name, &sym->declared_at, guessed);
> +	  else
> +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> +		       sym->name, &sym->declared_at);
>   	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
>   	}
>
> @@ -2188,6 +2252,55 @@ bad:
>   }
>
>
> +/* Recursively append candidate COMPONENT structures to CANDIDATES.  */
> +
> +static void
> +lookup_component_fuzzy_find_candidates (gfc_component *component,
> +				        vec<const char *> *candidates)
> +{
> +  for (gfc_component *p = component; p; p = p->next)
> +    {
> +      if (00 && p->ts.type == BT_DERIVED)
> +	/* ??? There's no (suitable) DERIVED_TYPE which would come in
> +	   handy throughout the frontend; Use CLASS_DATA here for brevity.  */
> +	lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
I don't understand what you are looking for here.
Are you trying to handle type extension?  Then I guess you would have to 
pass the derived type symbol instead of its components, and use 
gfc_get_derived_super_type to retrieve the parent type.

Mikael

[PATCH] v2 Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[David Malcolm]

[-- Attachment #1: Type: text/plain, Size: 9084 bytes --]

On Sat, 2015-12-05 at 20:53 +0100, Mikael Morin wrote:
> Hello,
> 
> to get things moving again, a few comments on top of David Malcolm's:
> 
> Le 01/12/2015 13:55, Bernhard Reutner-Fischer a écrit :
> >
> > David Malcolm nice Levenshtein distance spelling check helpers
> > were used in some parts of other frontends. This proposed patch adds
> > some spelling corrections to the fortran frontend.
> >
> > Suggestions are printed if we can find a suitable name, currently
> > perusing a very simple cutoff factor:
> > /* If more than half of the letters were misspelled, the suggestion is
> >     likely to be meaningless.  */
> > cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
> > which effectively skips names with less than 4 characters.
> > For e.g. structures, one could try to be much smarter in an attempt to
> > also provide suggestions for single-letter members/components.
> >
> > This patch covers (at least partly):
> > - user-defined operators
> > - structures (types and their components)
> > - functions
> > - symbols (variables)
> >
> > I do not immediately see how to handle subroutines. Ideas?
> >
> Not sure what you are looking for; I can get an error generated in 
> gfc_procedure_use if using IMPLICIT NONE (EXTERNAL)
> 
> > If anybody has a testcase where a spelling-suggestion would make sense
> > then please pass it along so we maybe can add support for GCC-7.
> >
> 
> 
> > diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> > index 685e3f5..6e1f63c 100644
> > --- a/gcc/fortran/resolve.c
> > +++ b/gcc/fortran/resolve.c
> > @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3.  If not see
> >   #include "data.h"
> >   #include "target-memory.h" /* for gfc_simplify_transfer */
> >   #include "constructor.h"
> > +#include "spellcheck.h"
> >
> >   /* Types used in equivalence statements.  */
> >
> > @@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
> >     return true;
> >   }
> >
> > +/* Recursively append candidate SYM to CANDIDATES.  */
> > +
> > +static void
> > +lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
> > +                                       vec<const char *> *candidates)
> > +{
> > +  gfc_symtree *p;
> > +  for (p = sym->right; p; p = p->right)
> > +    {
> > +      lookup_function_fuzzy_find_candidates (p, candidates);
> > +      if (p->n.sym->ts.type != BT_UNKNOWN)
> > +	candidates->safe_push (p->name);
> > +    }
> > +  for (p = sym->left; p; p = p->left)
> > +    {
> > +      lookup_function_fuzzy_find_candidates (p, candidates);
> > +      if (p->n.sym->ts.type != BT_UNKNOWN)
> > +	candidates->safe_push (p->name);
> > +    }
> > +}
> 
> It seems you are considering some candidates more than once here.
> The first time through the recursive call you will consider say 
> sym->right->right, and with the loop, you'll consider it again after 
> returning from the recursive call.
> The usual way to traverse the whole tree is to handle the current 
> pointer and recurse on left and right pointers.  So without loop.
> There is gfc_traverse_ns that you might find handy to do that (no 
> obligation).
> 
> Same goes for the user operators below.
> 
> > +
> > +
> > +/* Lookup function FN fuzzily, taking names in FUN into account.  */
> > +
> > +const char*
> > +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
> > +{
> > +  auto_vec <const char *> candidates;
> > +  lookup_function_fuzzy_find_candidates (fun, &candidates);
> 
> You have to start the lookup with the current namespace's sym_root (not 
> with fun), otherwise you'll miss some candidates.
> You may also want to query parent namespaces for host-associated symbols.
> 
> > +
> > +  /* Determine closest match.  */
> > +  int i;
> > +  const char *name, *best = NULL;
> > +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> > +
> 
> [...]
> 
> > diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> > index ff9aff9..212f7d8 100644
> > --- a/gcc/fortran/symbol.c
> > +++ b/gcc/fortran/symbol.c
> > @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
> >   #include "parse.h"
> >   #include "match.h"
> >   #include "constructor.h"
> > +#include "spellcheck.h"
> >
> >
> >   /* Strings for all symbol attributes.  We use these for dumping the
> > @@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
> >   }
> >
> >
> > +/* Recursively append candidate SYM to CANDIDATES.  */
> > +
> > +static void
> > +lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
> > +				        vec<const char *> *candidates)
> > +{
> > +  gfc_symtree *p;
> > +  for (p = sym->right; p; p = p->right)
> > +    {
> > +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> > +      if (p->n.sym->ts.type != BT_UNKNOWN)
> > +	candidates->safe_push (p->name);
> > +    }
> > +  for (p = sym->left; p; p = p->left)
> > +    {
> > +      lookup_symbol_fuzzy_find_candidates (p, candidates);
> > +      if (p->n.sym->ts.type != BT_UNKNOWN)
> > +	candidates->safe_push (p->name);
> > +    }
> > +}
> This looks like the same as lookup_function_fuzzy_find_candidates, isn't it?
> Maybe have a general symbol traversal function with a selection callback 
> argument to test whether the symbol is what you want, depending on the 
> context (is it a function? a subroutine? etc).
> 
> > +
> > +
> > +/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account.  */
> > +
> > +static const char*
> > +lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
> > +{
> > +  auto_vec <const char *> candidates;
> > +  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
> > +
> > +  /* Determine closest match.  */
> > +  int i;
> > +  const char *name, *best = NULL;
> > +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> > +
> > +  FOR_EACH_VEC_ELT (candidates, i, name)
> > +    {
> > +      edit_distance_t dist = levenshtein_distance (sym, name);
> > +      if (dist < best_distance)
> > +	{
> > +	  best_distance = dist;
> > +	  best = name;
> > +	}
> > +    }
> > +  /* If more than half of the letters were misspelled, the suggestion is
> > +     likely to be meaningless.  */
> > +  if (best)
> > +    {
> > +      unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
> > +      if (best_distance > cutoff)
> > +	return NULL;
> > +    }
> > +  return best;
> > +}
> > +
> > +
> >   /* Given a pointer to a symbol, set its type according to the first
> >      letter of its name.  Fails if the letter in question has no default
> >      type.  */
> > @@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
> >       {
> >         if (error_flag && !sym->attr.untyped)
> >   	{
> > -	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> > -		     sym->name, &sym->declared_at);
> > +	  const char *guessed
> > +	    = lookup_symbol_fuzzy (sym->name, sym);
> > +	  if (guessed)
> > +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
> > +		       "; did you mean %qs?",
> > +		       sym->name, &sym->declared_at, guessed);
> > +	  else
> > +	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
> > +		       sym->name, &sym->declared_at);
> >   	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
> >   	}
> >
> > @@ -2188,6 +2252,55 @@ bad:
> >   }
> >
> >
> > +/* Recursively append candidate COMPONENT structures to CANDIDATES.  */
> > +
> > +static void
> > +lookup_component_fuzzy_find_candidates (gfc_component *component,
> > +				        vec<const char *> *candidates)
> > +{
> > +  for (gfc_component *p = component; p; p = p->next)
> > +    {
> > +      if (00 && p->ts.type == BT_DERIVED)
> > +	/* ??? There's no (suitable) DERIVED_TYPE which would come in
> > +	   handy throughout the frontend; Use CLASS_DATA here for brevity.  */
> > +	lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
> I don't understand what you are looking for here.
> Are you trying to handle type extension?  Then I guess you would have to 
> pass the derived type symbol instead of its components, and use 
> gfc_get_derived_super_type to retrieve the parent type.

I can't comment on Mikael's observations, but here's an updated version
of Bernhard's patch which moves the duplicated code into a new
"find_closest_string" function in gcc/spellcheck.c.  
With that, the lookup_*_fuzzy functions are all of the form:

{
  auto_vec <const char *> candidates;

  /* call something to populate candidates e.g.: */
  lookup_function_fuzzy_find_candidates (fun, &candidates);

  return find_closest_string (fn, &candidates);
}

where, as before, the auto_vec is implicitly cleaned up via a
C++ destructor as the function exits.  Hopefully with this change it
reduces the amount of proposed C++ in the fortran subdirectory to an
palatable amount.

That's all I did; I didn't address the other issues seen in this thread
(e.g. Mikael's notes above).

Not yet well-tested; it compiles and passes the new test cases; I'm
posting it here in case someone more familiar with the Fortran FE wants
to take this forward (Bernhard?)

Hope this is constructive
Dave

[-- Attachment #2: 0001-RFC-Use-Levenshtein-spelling-suggestions-in-Fortran-.patch --]
[-- Type: text/x-patch, Size: 17936 bytes --]

From 3d604c7ca75e6293be5a84546b7f34bee48d3d92 Mon Sep 17 00:00:00 2001
From: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
Date: Tue, 1 Dec 2015 13:55:01 +0100
Subject: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE (v2)

gcc/fortran/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
	David Malcolm <dmalcolm@redhat.com>

	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
	* interface.c (check_interface0): Call gfc_lookup_function_fuzzy
	and use it to potentially suggest a hint for misspelled names.
	* resolve.c: Include spellcheck.h.
	(lookup_function_fuzzy_find_candidates): New static function.
	(lookup_uop_fuzzy_find_candidates): Likewise.
	(lookup_uop_fuzzy): Likewise.
	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
	(gfc_lookup_function_fuzzy): New definition.
	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
	* symbol.c: Include spellcheck.h.
	(lookup_symbol_fuzzy_find_candidates): New static function.
	(lookup_symbol_fuzzy): Likewise.
	(gfc_set_default_type): Call lookup_symbol_fuzzy.
	(lookup_component_fuzzy_find_candidates): New static function.
	(lookup_component_fuzzy): Likewise.
	(gfc_find_component): Call lookup_component_fuzzy.

gcc/ChangeLog:
	David Malcolm <dmalcolm@redhat.com>
	* spellcheck.c (find_closest_string): New function.
	* spellcheck.h (find_closest_string): New decl.

gcc/testsuite/ChangeLog

2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/spellcheck-operator.f90: New testcase.
	* gfortran.dg/spellcheck-procedure.f90: New testcase.
	* gfortran.dg/spellcheck-structure.f90: New testcase.
---
 gcc/fortran/gfortran.h                             |  1 +
 gcc/fortran/interface.c                            | 16 +++-
 gcc/fortran/resolve.c                              | 89 +++++++++++++++++++++-
 gcc/fortran/symbol.c                               | 83 +++++++++++++++++++-
 gcc/spellcheck.c                                   | 43 +++++++++++
 gcc/spellcheck.h                                   |  4 +
 gcc/testsuite/gfortran.dg/spellcheck-operator.f90  | 30 ++++++++
 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 | 41 ++++++++++
 gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 +++++++++
 9 files changed, 331 insertions(+), 11 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9f61e45..7972c3c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3085,6 +3085,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
 
 
 /* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f74239d..3066d68 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1590,10 +1590,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 	  if (p->sym->attr.external)
 	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
 		       p->sym->name, interface_name, &p->sym->declared_at);
-	  else
-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
-		       "subroutine", p->sym->name, interface_name,
-		      &p->sym->declared_at);
+	  else {
+	    const char *guessed
+	      = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine; did you mean %qs?", p->sym->name,
+			interface_name, &p->sym->declared_at, guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine", p->sym->name, interface_name,
+			&p->sym->declared_at);
+	  }
 	  return 1;
 	}
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 10add62..547930f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "data.h"
 #include "target-memory.h" /* for gfc_simplify_transfer */
 #include "constructor.h"
+#include "spellcheck.h"
 
 /* Types used in equivalence statements.  */
 
@@ -2682,6 +2683,38 @@ resolve_specific_f (gfc_expr *expr)
   return true;
 }
 
+/* Recursively append candidate SYM to CANDIDATES.  */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+                                       vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  for (p = sym->right; p; p = p->right)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+  for (p = sym->left; p; p = p->left)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+}
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account.  */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+  auto_vec <const char *> candidates;
+  lookup_function_fuzzy_find_candidates (fun, &candidates);
+  return find_closest_string (fn, &candidates);
+}
+
 
 /* Resolve a procedure call not known to be generic nor specific.  */
 
@@ -2732,8 +2765,15 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
-		     sym->name, &expr->where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &expr->where, guessed);
+	  else
+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
+		       sym->name, &expr->where);
 	  return false;
 	}
       else
@@ -3504,6 +3544,40 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
   return t;
 }
 
+/* Recursively append candidate UOP to CANDIDATES.  */
+
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+				  vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  /* Not sure how to properly filter here.  Use all for a start.
+     n.uop.op is NULL for empty interface operators (is that legal?) disregard
+     these as i suppose they don't make terribly sense.  */
+  for (p = uop->right; p; p = p->right)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.uop->op != NULL)
+	candidates->safe_push (p->name);
+    }
+  for (p = uop->left; p; p = p->left)
+    {
+      lookup_function_fuzzy_find_candidates (p, candidates);
+      if (p->n.uop->op != NULL)
+	candidates->safe_push (p->name);
+    }
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+  auto_vec <const char *> candidates;
+  lookup_uop_fuzzy_find_candidates (uop, &candidates);
+  return find_closest_string (op, &candidates);
+}
+
 
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
@@ -3703,7 +3777,16 @@ resolve_operator (gfc_expr *e)
 
     case INTRINSIC_USER:
       if (e->value.op.uop->op == NULL)
-	sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+	{
+	  const char *name = e->value.op.uop->name;
+	  const char *guessed;
+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+	  if (guessed)
+	    sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+		name, guessed);
+	  else
+	    sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
 		 e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..75f9b6d 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "parse.h"
 #include "match.h"
 #include "constructor.h"
+#include "spellcheck.h"
 
 
 /* Strings for all symbol attributes.  We use these for dumping the
@@ -235,6 +236,39 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
 }
 
 
+/* Recursively append candidate SYM to CANDIDATES.  */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+				        vec<const char *> *candidates)
+{
+  gfc_symtree *p;
+  for (p = sym->right; p; p = p->right)
+    {
+      lookup_symbol_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+  for (p = sym->left; p; p = p->left)
+    {
+      lookup_symbol_fuzzy_find_candidates (p, candidates);
+      if (p->n.sym->ts.type != BT_UNKNOWN)
+	candidates->safe_push (p->name);
+    }
+}
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account.  */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+  auto_vec <const char *> candidates;
+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+  return find_closest_string (sym, &candidates);
+}
+
+
 /* Given a pointer to a symbol, set its type according to the first
    letter of its name.  Fails if the letter in question has no default
    type.  */
@@ -253,8 +287,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     {
       if (error_flag && !sym->attr.untyped)
 	{
-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
-		     sym->name, &sym->declared_at);
+	  const char *guessed
+	    = lookup_symbol_fuzzy (sym->name, sym);
+	  if (guessed)
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &sym->declared_at, guessed);
+	  else
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
 
@@ -2188,6 +2229,32 @@ bad:
 }
 
 
+/* Recursively append candidate COMPONENT structures to CANDIDATES.  */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+				        vec<const char *> *candidates)
+{
+  for (gfc_component *p = component; p; p = p->next)
+    {
+      if (00 && p->ts.type == BT_DERIVED)
+	/* ??? There's no (suitable) DERIVED_TYPE which would come in
+	   handy throughout the frontend; Use CLASS_DATA here for brevity.  */
+	lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
+      candidates->safe_push (p->name);
+    }
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+  auto_vec <const char *> candidates;
+  lookup_component_fuzzy_find_candidates (component, &candidates);
+  return find_closest_string (member, &candidates);
+}
+
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
    not found or the components are private.  If noaccess is set, no access
@@ -2238,8 +2305,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
     }
 
   if (p == NULL && !silent)
-    gfc_error ("%qs at %C is not a member of the %qs structure",
-	       name, sym->name);
+    {
+      const char *guessed = lookup_component_fuzzy (name, sym->components);
+      if (guessed)
+	gfc_error ("%qs at %C is not a member of the %qs structure"
+		   "; did you mean %qs?",
+		   name, sym->name, guessed);
+      else
+	gfc_error ("%qs at %C is not a member of the %qs structure",
+		   name, sym->name);
+    }
 
   return p;
 }
diff --git a/gcc/spellcheck.c b/gcc/spellcheck.c
index 32854cf..be4cef9 100644
--- a/gcc/spellcheck.c
+++ b/gcc/spellcheck.c
@@ -119,3 +119,46 @@ levenshtein_distance (const char *s, const char *t)
 {
   return levenshtein_distance (s, strlen (s), t, strlen (t));
 }
+
+/* Given TARGET, a non-NULL string, and CANDIDATES, a vec of non-NULL
+   strings, determine which element within CANDIDATES has the lowest edit
+   distance to TARGET.  If there are multiple elements with the
+   same minimal distance, the first in the vector wins.
+
+   If more than half of the letters were misspelled, the suggestion is
+   likely to be meaningless, so return NULL for this case.  */
+
+const char *
+find_closest_string (const char *target,
+		     const auto_vec<const char *> *candidates)
+{
+  gcc_assert (target);
+  gcc_assert (candidates);
+
+  int i;
+  const char *string, *best_string = NULL;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+  size_t len_target = strlen (target);
+  FOR_EACH_VEC_ELT (*candidates, i, string)
+    {
+      gcc_assert (string);
+      edit_distance_t dist = levenshtein_distance (target, len_target,
+						   string, strlen (string));
+      if (dist < best_distance)
+	{
+	  best_distance = dist;
+	  best_string = string;
+	}
+    }
+
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best_string)
+    {
+      unsigned int cutoff = MAX (len_target, strlen (best_string)) / 2;
+      if (best_distance > cutoff)
+	return NULL;
+    }
+
+  return best_string;
+}
diff --git a/gcc/spellcheck.h b/gcc/spellcheck.h
index ad02998..1100d15 100644
--- a/gcc/spellcheck.h
+++ b/gcc/spellcheck.h
@@ -31,6 +31,10 @@ levenshtein_distance (const char *s, int len_s,
 extern edit_distance_t
 levenshtein_distance (const char *s, const char *t);
 
+extern const char *
+find_closest_string (const char *target,
+		     const auto_vec<const char *> *candidates);
+
 /* spellcheck-tree.c  */
 
 extern edit_distance_t
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  interface operator (.mywrong.)
+    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+  end interface
+
+  interface operator (.mygood.)
+    module procedure something_good
+  end interface
+
+  integer :: i, j, added
+  i = 0
+  j = 0
+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
new file mode 100644
index 0000000..7923081
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+subroutine bark_unless_zero(iarg)
+  implicit none
+  integer, intent(in) :: iarg
+  if (iarg /= 0) call abort
+end subroutine bark_unless_zero
+
+function myadd(iarg1, iarg2)
+  implicit none
+  integer :: myadd
+  integer, intent(in) :: iarg1, iarg2
+  myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  integer :: i, j, myadd
+  i = 0
+  j = 0
+! I suppose this cannot be made to work, no\\?
+!  call barf_unless_zero(i) ! { -dg-error "; did you mean .bark_unless_zero.\\?" }
+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  j = mya(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  if (j /= 42) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+   real :: radius
+   integer :: i
+end type type1
+
+type type2
+  integer :: myint
+  type(type1) :: mytype
+end type type2
+
+type type3
+  type(type2) :: type_2
+end type type3
+type type4
+  type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end
-- 
1.8.5.3

Re: [PATCH] v2 Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Tobias Burnus]

David Malcolm wrote:
> On Sat, 2015-12-05 at 20:53 +0100, Mikael Morin wrote:
> > to get things moving again, a few comments on top of David Malcolm's:
[...]
> > It seems you are considering some candidates more than once here.
[...]
> > You have to start the lookup with the current namespace's sym_root (not 
> > with fun), otherwise you'll miss some candidates.
> > You may also want to query parent namespaces for host-associated symbols.
[...]

I think the current patch doesn't not address those (as stated) and I think
that some suggestions should honour the attributes better (variable vs.
subroutine vs. function etc.). But I very much like the general patch.

Regarding Malcolm's update:
> I can't comment on Mikael's observations, but here's an updated version
> of Bernhard's patch which moves the duplicated code into a new
> "find_closest_string" function in gcc/spellcheck.c.

That change looks good to me.

BTW: I think you should write a quip for https://gcc.gnu.org/gcc-6/changes.html

Tobias

PS: Talking about the release notes, my feeling is that both the wiki and
the release notes miss some changes, but I have to admit that I am really
out of sync. It currently only lists Submodules at the Wiki,
   https://gcc.gnu.org/wiki/GFortran/News#GCC6
and https://gcc.gnu.org/gcc-6/changes.html has a few other items. (Both
should be synced crosswise.) As additional item, I know of coarray events
but there must be more items.

Re: [PATCH] v2 Re: [PATCH] RFC: Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

On December 9, 2015 2:07:05 AM GMT+01:00, David Malcolm <dmalcolm@redhat.com> wrote:

>I can't comment on Mikael's observations, but here's an updated version
>of Bernhard's patch which moves the duplicated code into a new
>"find_closest_string" function in gcc/spellcheck.c.  
>With that, the lookup_*_fuzzy functions are all of the form:
>
>{
>  auto_vec <const char *> candidates;
>
>  /* call something to populate candidates e.g.: */
>  lookup_function_fuzzy_find_candidates (fun, &candidates);
>
>  return find_closest_string (fn, &candidates);
>}
>
>where, as before, the auto_vec is implicitly cleaned up via a
>C++ destructor as the function exits.  Hopefully with this change it
>reduces the amount of proposed C++ in the fortran subdirectory to an
>palatable amount.
>
>That's all I did; I didn't address the other issues seen in this thread
>(e.g. Mikael's notes above).
>
>Not yet well-tested; it compiles and passes the new test cases; I'm
>posting it here in case someone more familiar with the Fortran FE wants
>to take this forward (Bernhard?)

I have rewritten the autovec to plain c, will send an updated patch including current comments and maybe the parameter handling as suggested by Joost when done.

Thanks,
>
>Hope this is constructive
>Dave

Fortran release notes (was: [PATCH] v2 ...)

[Gerald Pfeifer]

On Thu, 10 Dec 2015, Tobias Burnus wrote:
> PS: Talking about the release notes, my feeling is that both the wiki and
> the release notes miss some changes, but I have to admit that I am really
> out of sync. It currently only lists Submodules at the Wiki,
>    https://gcc.gnu.org/wiki/GFortran/News#GCC6
> and https://gcc.gnu.org/gcc-6/changes.html has a few other items. (Both
> should be synced crosswise.)

I would be really good to see all changes land in changes.html in
time, since this is what the majority of users -- and press, as I 
have seen -- consumes.

(Why do the Wiki and the formal release notes need to be synced
cross-wise?  Couldn't you just move things from the Wiki to the
release notes to avoid duplication?)

Gerald

[PATCH, RFC, v2] Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

gcc/fortran/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
	(gfc_closest_fuzzy_match): New declaration.
	(vec_push): New definition.
	* misc.c (gfc_closest_fuzzy_match): New definition.
	* resolve.c: Include spellcheck.h.
	(lookup_function_fuzzy_find_candidates): New static function.
	(lookup_uop_fuzzy_find_candidates): Likewise.
	(lookup_uop_fuzzy): Likewise.
	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
	(gfc_lookup_function_fuzzy): New definition.
	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
	* interface.c (check_interface0): Likewise.
	(lookup_arg_fuzzy_find_candidates): New static function.
	(lookup_arg_fuzzy ): Likewise.
	(compare_actual_formal): Call lookup_arg_fuzzy.
	* symbol.c: Include spellcheck.h.
	(lookup_symbol_fuzzy_find_candidates): New static function.
	(lookup_symbol_fuzzy): Likewise.
	(gfc_set_default_type): Call lookup_symbol_fuzzy.
	(lookup_component_fuzzy_find_candidates): New static function.
	(lookup_component_fuzzy): Likewise.
	(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/spellcheck-operator.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
	* gfortran.dg/spellcheck-structure.f90: New testcase.
	* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
   likely to be meaningless.  */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/gfortran.h                             | 12 +++
 gcc/fortran/interface.c                            | 72 ++++++++++++++--
 gcc/fortran/misc.c                                 | 39 +++++++++
 gcc/fortran/resolve.c                              | 99 +++++++++++++++++++++-
 gcc/fortran/symbol.c                               | 84 +++++++++++++++++-
 gcc/testsuite/gfortran.dg/spellcheck-operator.f90  | 30 +++++++
 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 | 15 ++++
 .../gfortran.dg/spellcheck-procedure_1.f90         | 41 +++++++++
 .../gfortran.dg/spellcheck-procedure_2.f90         | 35 ++++++++
 gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++++
 10 files changed, 446 insertions(+), 16 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..93f0887 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2641,6 +2641,17 @@ void gfc_done_2 (void);
 
 int get_c_kind (const char *, CInteropKind_t *);
 
+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+  /* {auto,}vec.safe_push () replacement.  Don't ask..  */
+  // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+  optr = XRESIZEVEC (char *, optr, osz + 2);
+  optr[osz] = CONST_CAST (char *, elt);
+  optr[++osz] = NULL;
+}
+
 /* options.c */
 unsigned int gfc_option_lang_mask (void);
 void gfc_init_options_struct (struct gcc_options *);
@@ -3060,6 +3071,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
 
 
 /* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30cc522..eb9bc6a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1587,13 +1587,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 	   || !p->sym->attr.if_source)
 	  && p->sym->attr.flavor != FL_DERIVED)
 	{
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
 	  if (p->sym->attr.external)
-	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
-		       p->sym->name, interface_name, &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+			 "; did you mean %qs?",
+			 p->sym->name, interface_name, &p->sym->declared_at,
+			 guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+			 p->sym->name, interface_name, &p->sym->declared_at);
 	  else
-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
-		       "subroutine", p->sym->name, interface_name,
-		      &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine; did you mean %qs?", p->sym->name,
+			interface_name, &p->sym->declared_at, guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine", p->sym->name, interface_name,
+			&p->sym->declared_at);
 	  return 1;
 	}
 
@@ -2559,6 +2573,31 @@ is_procptr_result (gfc_expr *expr)
 }
 
 
+/* Recursively append candidate argument ARG to CANDIDATES.  Store the
+   number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+    vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account.  */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
 /* Given formal and actual argument lists, see if they are compatible.
    If they are compatible, the actual argument list is sorted to
    correspond with the formal list, and elements for missing optional
@@ -2611,8 +2650,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  if (f == NULL)
 	    {
 	      if (where)
-		gfc_error ("Keyword argument %qs at %L is not in "
-			   "the procedure", a->name, &a->expr->where);
+		{
+		  const char *guessed = lookup_arg_fuzzy (a->name, formal);
+		  if (guessed)
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure; did you mean %qs?",
+			       a->name, &a->expr->where, guessed);
+		  else
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure", a->name, &a->expr->where);
+		}
 	      return 0;
 	    }
 
@@ -3311,8 +3358,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
     {
       if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
 	{
-	  gfc_error ("Procedure %qs called at %L is not explicitly declared",
-		     sym->name, where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared"
+		       "; did you mean %qs?",
+		       sym->name, where, guessed);
+	  else
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared",
+		       sym->name, where);
 	  return false;
 	}
       if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 34ed04a..db51aef 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "gfortran.h"
+#include "spellcheck.h"
 
 
 /* Initialize a typespec to unknown.  */
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 
   return ISOCBINDING_INVALID;
 }
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+   perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+  /* Determine closest match.  */
+  const char *best = NULL;
+  char **cand = candidates;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  while (cand && *cand)
+    {
+      edit_distance_t dist = levenshtein_distance (typo, *cand);
+      if (dist < best_distance)
+	{
+	   best_distance = dist;
+	   best = *cand;
+	}
+      cand++;
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+      if (best_distance > cutoff)
+	{
+	  XDELETEVEC (candidates);
+	  return NULL;
+	}
+      XDELETEVEC (candidates);
+    }
+  return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..37775b1 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2682,6 +2682,43 @@ resolve_specific_f (gfc_expr *expr)
   return true;
 }
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+				       char **&candidates,
+				       size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+  if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+      && sym->n.sym->attr.flavor == FL_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+
+  p = sym->left;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account.  */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (fn, candidates);
+}
+
 
 /* Resolve a procedure call not known to be generic nor specific.  */
 
@@ -2732,8 +2769,15 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
-		     sym->name, &expr->where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &expr->where, guessed);
+	  else
+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
+		       sym->name, &expr->where);
 	  return false;
 	}
       else
@@ -3505,6 +3549,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
 }
 
 
+/* Recursively append candidate UOP to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (uop == NULL)
+    return;
+
+  /* Not sure how to properly filter here.  Use all for a start.
+     n.uop.op is NULL for empty interface operators (is that legal?) disregard
+     these as i suppose they don't make terribly sense.  */
+
+  if (uop->n.uop->op != NULL)
+    vec_push (candidates, candidates_len, uop->name);
+
+  p = uop->left;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = uop->right;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
 
@@ -3703,7 +3787,16 @@ resolve_operator (gfc_expr *e)
 
     case INTRINSIC_USER:
       if (e->value.op.uop->op == NULL)
-	sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+	{
+	  const char *name = e->value.op.uop->name;
+	  const char *guessed;
+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+	  if (guessed)
+	    sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+		name, guessed);
+	  else
+	    sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
 		 e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..1499603 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -235,6 +235,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
 }
 
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+				     char **&candidates,
+				     size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+
+  if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+  p = sym->left;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account.  */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+				       candidates_len);
+  return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
 /* Given a pointer to a symbol, set its type according to the first
    letter of its name.  Fails if the letter in question has no default
    type.  */
@@ -253,8 +291,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     {
       if (error_flag && !sym->attr.untyped)
 	{
-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
-		     sym->name, &sym->declared_at);
+	  const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+	  if (guessed)
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &sym->declared_at, guessed);
+	  else
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
 
@@ -2188,6 +2232,30 @@ bad:
 }
 
 
+/* Recursively append candidate COMPONENT structures to CANDIDATES.  Store
+   the number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+					char **&candidates,
+					size_t &candidates_len)
+{
+  for (gfc_component *p = component; p; p = p->next)
+    vec_push (candidates, candidates_len, p->name);
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_component_fuzzy_find_candidates (component, candidates,
+					  candidates_len);
+  return gfc_closest_fuzzy_match (member, candidates);
+}
+
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
    not found or the components are private.  If noaccess is set, no access
@@ -2238,8 +2306,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
     }
 
   if (p == NULL && !silent)
-    gfc_error ("%qs at %C is not a member of the %qs structure",
-	       name, sym->name);
+    {
+      const char *guessed = lookup_component_fuzzy (name, sym->components);
+      if (guessed)
+	gfc_error ("%qs at %C is not a member of the %qs structure"
+		   "; did you mean %qs?",
+		   name, sym->name, guessed);
+      else
+	gfc_error ("%qs at %C is not a member of the %qs structure",
+		   name, sym->name);
+    }
 
   return p;
 }
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  interface operator (.mywrong.)
+    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+  end interface
+
+  interface operator (.mygood.)
+    module procedure something_good
+  end interface
+
+  integer :: i, j, added
+  i = 0
+  j = 0
+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+  subroutine mysub(iarg1)
+    integer :: iarg1
+  end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_else (iarg1)
+      integer :: something_else
+      integer, intent(in) :: iarg1
+      something_else = iarg1 + 42
+    end function something_else
+    function add_fourtytwo (iarg1)
+      integer :: add_fourtytwo
+      integer, intent(in) :: iarg1
+      add_fourtytwo = iarg1 + 42
+    end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+  implicit none
+  integer :: myadd
+  integer, intent(in) :: iarg1, iarg2
+  myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+  use mymod1, something_good => something_else
+  implicit none
+
+  integer :: myadd, i, j, myvar
+  i = 0
+  j = 0
+
+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  if (j /= 42) call abort
+  j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+  myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+  if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..fbd4dcd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+  implicit none (external)
+
+  interface
+    subroutine bark_unless_zero(iarg)
+      implicit none
+      integer, intent(in) :: iarg
+    end subroutine bark_unless_zero
+  end interface
+
+  integer :: i
+  i = 0
+
+  if (i /= 1) call abort
+  call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+!  call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+  subroutine complain_about_zero(iarg)
+    integer, intent(in) :: iarg
+    if (iarg /= 0) call abort
+  end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+  implicit none
+  integer, intent(in) :: iarg
+  if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+   real :: radius
+   integer :: i
+end type type1
+
+type type2
+  integer :: myint
+  type(type1) :: mytype
+end type type2
+
+type type3
+  type(type2) :: type_2
+end type type3
+type type4
+  type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end
-- 
2.6.4

[PATCH, fortran, v3] Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

Changes for v2 -> v3:

- rebased

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

gcc/fortran/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
	(gfc_closest_fuzzy_match): New declaration.
	(vec_push): New definition.
	* misc.c (gfc_closest_fuzzy_match): New definition.
	* resolve.c: Include spellcheck.h.
	(lookup_function_fuzzy_find_candidates): New static function.
	(lookup_uop_fuzzy_find_candidates): Likewise.
	(lookup_uop_fuzzy): Likewise.
	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
	(gfc_lookup_function_fuzzy): New definition.
	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
	* interface.c (check_interface0): Likewise.
	(lookup_arg_fuzzy_find_candidates): New static function.
	(lookup_arg_fuzzy ): Likewise.
	(compare_actual_formal): Call lookup_arg_fuzzy.
	* symbol.c: Include spellcheck.h.
	(lookup_symbol_fuzzy_find_candidates): New static function.
	(lookup_symbol_fuzzy): Likewise.
	(gfc_set_default_type): Call lookup_symbol_fuzzy.
	(lookup_component_fuzzy_find_candidates): New static function.
	(lookup_component_fuzzy): Likewise.
	(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/spellcheck-operator.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
	* gfortran.dg/spellcheck-structure.f90: New testcase.
	* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
   likely to be meaningless.  */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
- subroutines using interfaces
- keyword arguments (named parameters)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/gfortran.h                             |  12 +++
 gcc/fortran/interface.c                            |  72 +++++++++++++--
 gcc/fortran/misc.c                                 |  39 ++++++++
 gcc/fortran/resolve.c                              | 100 ++++++++++++++++++++-
 gcc/fortran/symbol.c                               |  84 ++++++++++++++++-
 gcc/testsuite/gfortran.dg/spellcheck-operator.f90  |  30 +++++++
 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 |  15 ++++
 .../gfortran.dg/spellcheck-procedure_1.f90         |  41 +++++++++
 .../gfortran.dg/spellcheck-procedure_2.f90         |  35 ++++++++
 gcc/testsuite/gfortran.dg/spellcheck-structure.f90 |  35 ++++++++
 10 files changed, 446 insertions(+), 17 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 33fffd8..5c0c403 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2669,6 +2669,17 @@ void gfc_done_2 (void);
 
 int get_c_kind (const char *, CInteropKind_t *);
 
+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+  /* {auto,}vec.safe_push () replacement.  Don't ask..  */
+  // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+  optr = XRESIZEVEC (char *, optr, osz + 2);
+  optr[osz] = CONST_CAST (char *, elt);
+  optr[++osz] = NULL;
+}
+
 /* options.c */
 unsigned int gfc_option_lang_mask (void);
 void gfc_init_options_struct (struct gcc_options *);
@@ -3088,6 +3099,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
 
 
 /* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ac53f01..ea64c0e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1587,13 +1587,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 	   || !p->sym->attr.if_source)
 	  && p->sym->attr.flavor != FL_DERIVED)
 	{
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
 	  if (p->sym->attr.external)
-	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
-		       p->sym->name, interface_name, &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+			 "; did you mean %qs?",
+			 p->sym->name, interface_name, &p->sym->declared_at,
+			 guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+			 p->sym->name, interface_name, &p->sym->declared_at);
 	  else
-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
-		       "subroutine", p->sym->name, interface_name,
-		      &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine; did you mean %qs?", p->sym->name,
+			interface_name, &p->sym->declared_at, guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine", p->sym->name, interface_name,
+			&p->sym->declared_at);
 	  return 1;
 	}
 
@@ -2577,6 +2591,31 @@ is_procptr_result (gfc_expr *expr)
 }
 
 
+/* Recursively append candidate argument ARG to CANDIDATES.  Store the
+   number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+    vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account.  */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
 /* Given formal and actual argument lists, see if they are compatible.
    If they are compatible, the actual argument list is sorted to
    correspond with the formal list, and elements for missing optional
@@ -2629,8 +2668,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  if (f == NULL)
 	    {
 	      if (where)
-		gfc_error ("Keyword argument %qs at %L is not in "
-			   "the procedure", a->name, &a->expr->where);
+		{
+		  const char *guessed = lookup_arg_fuzzy (a->name, formal);
+		  if (guessed)
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure; did you mean %qs?",
+			       a->name, &a->expr->where, guessed);
+		  else
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure", a->name, &a->expr->where);
+		}
 	      return 0;
 	    }
 
@@ -3329,8 +3376,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
     {
       if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
 	{
-	  gfc_error ("Procedure %qs called at %L is not explicitly declared",
-		     sym->name, where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared"
+		       "; did you mean %qs?",
+		       sym->name, where, guessed);
+	  else
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared",
+		       sym->name, where);
 	  return false;
 	}
       if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 405bae0..72ed311 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "gfortran.h"
+#include "spellcheck.h"
 
 
 /* Initialize a typespec to unknown.  */
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 
   return ISOCBINDING_INVALID;
 }
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+   perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+  /* Determine closest match.  */
+  const char *best = NULL;
+  char **cand = candidates;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+  while (cand && *cand)
+    {
+      edit_distance_t dist = levenshtein_distance (typo, *cand);
+      if (dist < best_distance)
+	{
+	   best_distance = dist;
+	   best = *cand;
+	}
+      cand++;
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+      if (best_distance > cutoff)
+	{
+	  XDELETEVEC (candidates);
+	  return NULL;
+	}
+      XDELETEVEC (candidates);
+    }
+  return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 556c846..27e4ddd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2687,6 +2687,43 @@ resolve_specific_f (gfc_expr *expr)
   return true;
 }
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+				       char **&candidates,
+				       size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+  if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+      && sym->n.sym->attr.flavor == FL_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+
+  p = sym->left;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account.  */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (fn, candidates);
+}
+
 
 /* Resolve a procedure call not known to be generic nor specific.  */
 
@@ -2737,8 +2774,15 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
-		     sym->name, &expr->where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &expr->where, guessed);
+	  else
+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
+		       sym->name, &expr->where);
 	  return false;
 	}
       else
@@ -3510,6 +3554,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
 }
 
 
+/* Recursively append candidate UOP to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (uop == NULL)
+    return;
+
+  /* Not sure how to properly filter here.  Use all for a start.
+     n.uop.op is NULL for empty interface operators (is that legal?) disregard
+     these as i suppose they don't make terribly sense.  */
+
+  if (uop->n.uop->op != NULL)
+    vec_push (candidates, candidates_len, uop->name);
+
+  p = uop->left;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = uop->right;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
 
@@ -3708,8 +3792,16 @@ resolve_operator (gfc_expr *e)
 
     case INTRINSIC_USER:
       if (e->value.op.uop->op == NULL)
-	sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
-		 e->value.op.uop->name);
+	{
+	  const char *name = e->value.op.uop->name;
+	  const char *guessed;
+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+	  if (guessed)
+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
+		name, guessed);
+	  else
+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
+	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
 		 e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 8efd12c..da7154e 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -235,6 +235,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
 }
 
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+				     char **&candidates,
+				     size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+
+  if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+  p = sym->left;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account.  */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+				       candidates_len);
+  return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
 /* Given a pointer to a symbol, set its type according to the first
    letter of its name.  Fails if the letter in question has no default
    type.  */
@@ -253,8 +291,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     {
       if (error_flag && !sym->attr.untyped)
 	{
-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
-		     sym->name, &sym->declared_at);
+	  const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+	  if (guessed)
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &sym->declared_at, guessed);
+	  else
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
 
@@ -2188,6 +2232,30 @@ bad:
 }
 
 
+/* Recursively append candidate COMPONENT structures to CANDIDATES.  Store
+   the number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+					char **&candidates,
+					size_t &candidates_len)
+{
+  for (gfc_component *p = component; p; p = p->next)
+    vec_push (candidates, candidates_len, p->name);
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_component_fuzzy_find_candidates (component, candidates,
+					  candidates_len);
+  return gfc_closest_fuzzy_match (member, candidates);
+}
+
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
    not found or the components are private.  If noaccess is set, no access
@@ -2238,8 +2306,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
     }
 
   if (p == NULL && !silent)
-    gfc_error ("%qs at %C is not a member of the %qs structure",
-	       name, sym->name);
+    {
+      const char *guessed = lookup_component_fuzzy (name, sym->components);
+      if (guessed)
+	gfc_error ("%qs at %C is not a member of the %qs structure"
+		   "; did you mean %qs?",
+		   name, sym->name, guessed);
+      else
+	gfc_error ("%qs at %C is not a member of the %qs structure",
+		   name, sym->name);
+    }
 
   return p;
 }
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  interface operator (.mywrong.)
+    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+  end interface
+
+  interface operator (.mygood.)
+    module procedure something_good
+  end interface
+
+  integer :: i, j, added
+  i = 0
+  j = 0
+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+  subroutine mysub(iarg1)
+    integer :: iarg1
+  end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_else (iarg1)
+      integer :: something_else
+      integer, intent(in) :: iarg1
+      something_else = iarg1 + 42
+    end function something_else
+    function add_fourtytwo (iarg1)
+      integer :: add_fourtytwo
+      integer, intent(in) :: iarg1
+      add_fourtytwo = iarg1 + 42
+    end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+  implicit none
+  integer :: myadd
+  integer, intent(in) :: iarg1, iarg2
+  myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+  use mymod1, something_good => something_else
+  implicit none
+
+  integer :: myadd, i, j, myvar
+  i = 0
+  j = 0
+
+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  if (j /= 42) call abort
+  j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+  myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+  if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..a6ea5f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+  implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE with spec list" }
+
+  interface
+    subroutine bark_unless_zero(iarg)
+      implicit none
+      integer, intent(in) :: iarg
+    end subroutine bark_unless_zero
+  end interface
+
+  integer :: i
+  i = 0
+
+  if (i /= 1) call abort
+  call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+!  call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+  subroutine complain_about_zero(iarg)
+    integer, intent(in) :: iarg
+    if (iarg /= 0) call abort
+  end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+  implicit none
+  integer, intent(in) :: iarg
+  if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+   real :: radius
+   integer :: i
+end type type1
+
+type type2
+  integer :: myint
+  type(type1) :: mytype
+end type type2
+
+type type3
+  type(type2) :: type_2
+end type type3
+type type4
+  type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end
-- 
2.7.0

Re: [PATCH, fortran, v3] Use Levenshtein spelling suggestions in Fortran FE

[David Malcolm]

On Sat, 2016-03-05 at 23:46 +0100, Bernhard Reutner-Fischer wrote:
[...]

> diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
> index 405bae0..72ed311 100644
> --- a/gcc/fortran/misc.c
> +++ b/gcc/fortran/misc.c
[...]

> @@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name,teropKind_tki
> nds_table[])
>  
>    return ISOCBINDING_INVALID;
>  }
> +
> +
> +/* For a given name TYPO, determine the best candidate from
> CANDIDATES
> +   perusing Levenshtein distance.  Frees CANDIDATES before
> returning.  */
> +
> +const char *
> +gfc_closest_fuzzy_match (const char *typo, char **candidates)
> +{
> +  /* Determine closest match.  */
> +  const char *best = NULL;
> +  char **cand = candidates;
> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> +
> +  while (cand && *cand)
> +    {
> +      edit_distance_t dist = levenshtein_distance (typo, *cand);
> +      if (dist < best_distance)
> +	{
> +	   best_distance = dist;
> +	   best = *cand;
> +	}
> +      cand++;
> +    }
> +  /* If more than half of the letters were misspelled, the
> suggestion is
> +     likely to be meaningless.  */
> +  if (best)
> +    {
> +      unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
> +
> +      if (best_distance > cutoff)
> +	{
> +	  XDELETEVEC (candidates);
> +	  return NULL;
> +	}
> +      XDELETEVEC (candidates);
> +    }
> +  return best;
> +}

FWIW, there are two overloaded variants of levenshtein_distance in
gcc/spellcheck.h, the first of which takes a pair of strlen values;
your patch uses the second one:

extern edit_distance_t
levenshtein_distance (const char *s, int len_s,
		      const char *t, int len_t);

extern edit_distance_t
levenshtein_distance (const char *s, const char *t);

So one minor tweak you may want to consider here is to calculate
  strlen (typo)
once at the top of gfc_closest_fuzzy_match, and then pass it in to the
4-arg variant of levenshtein_distance, which would avoid recalculating
strlen (typo) for every candidate.

I can't comment on the rest of the patch (I'm not a Fortran expert),
though it seems sane to 

Hope this is constructive
Dave

Re: [PATCH, fortran, v3] Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

On March 7, 2016 3:57:16 PM GMT+01:00, David Malcolm <dmalcolm@redhat.com> wrote:
>On Sat, 2016-03-05 at 23:46 +0100, Bernhard Reutner-Fischer wrote:
>[...]
>
>> diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
>> index 405bae0..72ed311 100644
>> --- a/gcc/fortran/misc.c
>> +++ b/gcc/fortran/misc.c
>[...]
>
>> @@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name,teropKind_tki
>> nds_table[])
>>  
>>    return ISOCBINDING_INVALID;
>>  }
>> +
>> +
>> +/* For a given name TYPO, determine the best candidate from
>> CANDIDATES
>> +   perusing Levenshtein distance.  Frees CANDIDATES before
>> returning.  */
>> +
>> +const char *
>> +gfc_closest_fuzzy_match (const char *typo, char **candidates)
>> +{
>> +  /* Determine closest match.  */
>> +  const char *best = NULL;
>> +  char **cand = candidates;
>> +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
>> +
>> +  while (cand && *cand)
>> +    {
>> +      edit_distance_t dist = levenshtein_distance (typo, *cand);
>> +      if (dist < best_distance)
>> +	{
>> +	   best_distance = dist;
>> +	   best = *cand;
>> +	}
>> +      cand++;
>> +    }
>> +  /* If more than half of the letters were misspelled, the
>> suggestion is
>> +     likely to be meaningless.  */
>> +  if (best)
>> +    {
>> +      unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
>> +
>> +      if (best_distance > cutoff)
>> +	{
>> +	  XDELETEVEC (candidates);
>> +	  return NULL;
>> +	}
>> +      XDELETEVEC (candidates);
>> +    }
>> +  return best;
>> +}
>
>FWIW, there are two overloaded variants of levenshtein_distance in
>gcc/spellcheck.h, the first of which takes a pair of strlen values;
>your patch uses the second one:
>
>extern edit_distance_t
>levenshtein_distance (const char *s, int len_s,
>		      const char *t, int len_t);
>
>extern edit_distance_t
>levenshtein_distance (const char *s, const char *t);
>
>So one minor tweak you may want to consider here is to calculate
>  strlen (typo)
>once at the top of gfc_closest_fuzzy_match, and then pass it in to the
>4-arg variant of levenshtein_distance, which would avoid recalculating
>strlen (typo) for every candidate.

I've pondered this back then but came to the conclusion to use the variant without len because to use the 4 argument variant I would have stored the candidates strlen in the vector too and was not convinced about the memory footprint for that would be justified. Maybe it is, but I would prefer the following tweak in the 4 argument variant:
If you would amend the 4 argument variant with a

  if (len_t == -1)
    len_t = strlen (t);
before the
   if (len_s == 0)
     return len_t;
   if (len_t == 0)
     return len_s;

checks then I'd certainly use the 4 arg variant :)

WDYT?
>
>I can't comment on the rest of the patch (I'm not a Fortran expert),
>though it seems sane to 
>
>Hope this is constructive

It is, thanks for your thoughts!

cheers,

Re: [PATCH, fortran, v3] Use Levenshtein spelling suggestions in Fortran FE

[David Malcolm]

On Sat, 2016-04-23 at 20:21 +0200, Bernhard Reutner-Fischer wrote:
> On March 7, 2016 3:57:16 PM GMT+01:00, David Malcolm <
> dmalcolm@redhat.com> wrote:
> > On Sat, 2016-03-05 at 23:46 +0100, Bernhard Reutner-Fischer wrote:
> > [...]
> > 
> > > diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
> > > index 405bae0..72ed311 100644
> > > --- a/gcc/fortran/misc.c
> > > +++ b/gcc/fortran/misc.c
> > [...]
> > 
> > > @@ -274,3 +275,41 @@ get_c_kind(const char
> > > *c_kind_name,teropKind_tki
> > > nds_table[])
> > >  
> > >    return ISOCBINDING_INVALID;
> > >  }
> > > +
> > > +
> > > +/* For a given name TYPO, determine the best candidate from
> > > CANDIDATES
> > > +   perusing Levenshtein distance.  Frees CANDIDATES before
> > > returning.  */
> > > +
> > > +const char *
> > > +gfc_closest_fuzzy_match (const char *typo, char **candidates)
> > > +{
> > > +  /* Determine closest match.  */
> > > +  const char *best = NULL;
> > > +  char **cand = candidates;
> > > +  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
> > > +
> > > +  while (cand && *cand)
> > > +    {
> > > +      edit_distance_t dist = levenshtein_distance (typo, *cand);
> > > +      if (dist < best_distance)
> > > +	{
> > > +	   best_distance = dist;
> > > +	   best = *cand;
> > > +	}
> > > +      cand++;
> > > +    }
> > > +  /* If more than half of the letters were misspelled, the
> > > suggestion is
> > > +     likely to be meaningless.  */
> > > +  if (best)
> > > +    {
> > > +      unsigned int cutoff = MAX (strlen (typo), strlen (best)) /
> > > 2;
> > > +
> > > +      if (best_distance > cutoff)
> > > +	{
> > > +	  XDELETEVEC (candidates);
> > > +	  return NULL;
> > > +	}
> > > +      XDELETEVEC (candidates);
> > > +    }
> > > +  return best;
> > > +}
> > 
> > FWIW, there are two overloaded variants of levenshtein_distance in
> > gcc/spellcheck.h, the first of which takes a pair of strlen values;
> > your patch uses the second one:
> > 
> > extern edit_distance_t
> > levenshtein_distance (const char *s, int len_s,
> > 		      const char *t, int len_t);
> > 
> > extern edit_distance_t
> > levenshtein_distance (const char *s, const char *t);
> > 
> > So one minor tweak you may want to consider here is to calculate
> >  strlen (typo)
> > once at the top of gfc_closest_fuzzy_match, and then pass it in to
> > the
> > 4-arg variant of levenshtein_distance, which would avoid
> > recalculating
> > strlen (typo) for every candidate.
> 
> I've pondered this back then but came to the conclusion to use the
> variant without len because to use the 4 argument variant I would
> have stored the candidates strlen in the vector too

Why would you need to do that?  You can simply call strlen inside the
loop instead; something like:

  size_t strlen_typo = strlen (typo);
  while (cand && *cand)
    {
      edit_distance_t dist = levenshtein_distance (typo, strlen_typo,
                                                   *cand, strlen (*cand));

etc

>  and was not convinced about the memory footprint for that would be
> justified. Maybe it is, but I would prefer the following tweak in the
> 4 argument variant:
> If you would amend the 4 argument variant with a
> 
>   if (len_t == -1)
>     len_t = strlen (t);
> before the
>    if (len_s == 0)
>      return len_t;
>    if (len_t == 0)
>      return len_s;
> 
> checks then I'd certainly use the 4 arg variant :)
> 
> WDYT?
> > 
> > I can't comment on the rest of the patch (I'm not a Fortran
> > expert),
> > though it seems sane to 
> > 
> > Hope this is constructive
> 
> It is, thanks for your thoughts!
> 
> cheers,
> 

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On December 3, 2015 10:46:09 AM GMT+01:00, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer
><rep.dot.nop@gmail.com> wrote:
>> On 1 December 2015 at 15:52, Janne Blomqvist
><blomqvist.janne@gmail.com> wrote:
>>> On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
>>> <rep.dot.nop@gmail.com> wrote:
>>>> These three function used a hardcoded buffer of 100 but would be
>better
>>>> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length
>of a
>>>> name in any of our supported standards (63 as of f2003 ff.).
>>>
>>> Please use xasprintf() instead (and free the result, or course). One
>>> of my backburner projects is to get rid of these static symbol
>>> buffers, and use dynamic buffers (or the symbol table) instead. We
>>> IIRC already have some ugly hacks by using hashing to get around
>>> GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
>>> make the situation worse per se, but if you're going to fix it, lets
>>> do it properly.
>>
>> I see.
>>
>> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
>> "^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
>> 142
>> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
>> 32
>
>Yes, that's why it's on the TODO-list rather than on the DONE-list. :)
>
>> What about memory fragmentation when switching to heap-based
>allocation?
>> Or is there consensus that these are in the noise compared to other
>> parts of the compiler?
>
>Heap fragmentation is an issue, yes. I'm not sure it's that
>performance-critical, but I don't think there is any consensus. I just
>want to avoid ugly hacks like symbol hashing to fit within some fixed
>buffer. Perhaps an good compromise would be something like std::string
>with small string optimization, but as you have seen there is some
>resistance to C++. But this is more relevant for mangled symbols, so
>GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
>few of them left. So, well, if you're sure that mangled symbols are
>never copied into the buffers your patch modifies, please consider
>your original patch Ok as well. Whichever you prefer.
>
>Performance-wise I think a bigger benefit would be to use the symbol
>table more and then e.g. be able to do pointer comparisons rather than
>strcmp(). But that is certainly much more work.

Hm, worth a look indeed since that would certainly be a step in the right direction.

>
>> BTW:
>> $ git grep APO
>> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",
>NULL };
>> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",
>NULL };
>
>? What are you saying?

delim is duplicated, we should remove one instance.
thanks,

Re: [PATCH] Use gfc_add_*_component defines where appropriate

[Bernhard Reutner-Fischer]

Ping.

On December 1, 2015 1:54:58 PM GMT+01:00, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>A couple of places used gfc_add_component_ref(expr, "string") instead
>of
>the defines from gfortran.h
>
>Regstrapped without regressions, ok for trunk stage3 now / next stage1?
>
>gcc/fortran/ChangeLog
>
>2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>
>     * class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
>        instead of gfc_add_component_ref().
>       (gfc_get_len_component): Call gfc_add_len_component() instead of
>        gfc_add_component_ref().
>        * trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
>        gfc_add_data_component() instead of gfc_add_component_ref().
>        * trans.c (gfc_add_finalizer_call): Call
>        gfc_add_final_component() and gfc_add_size_component() instead
>        of gfc_add_component_ref.
>
>Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
>---
> gcc/fortran/class.c           | 4 ++--
> gcc/fortran/trans-intrinsic.c | 2 +-
> gcc/fortran/trans.c           | 4 ++--
> 3 files changed, 5 insertions(+), 5 deletions(-)
>
>diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
>index 8b49ae9..027cb89 100644
>--- a/gcc/fortran/class.c
>+++ b/gcc/fortran/class.c
>@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
>   int rank = CLASS_DATA (e)->as->rank;
>   gfc_array_spec *as = CLASS_DATA (e)->as;
>   gfc_ref *ref = NULL;
>-  gfc_add_component_ref (e, "_data");
>+  gfc_add_data_component (e);
>   e->rank = rank;
>   for (ref = e->ref; ref; ref = ref->next)
>     if (!ref->next)
>@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
>       ref = ref->next;
>     }
>   /* And replace if with a ref to the _len component.  */
>-  gfc_add_component_ref (ptr, "_len");
>+  gfc_add_len_component (ptr);
>   return ptr;
> }
> 
>diff --git a/gcc/fortran/trans-intrinsic.c
>b/gcc/fortran/trans-intrinsic.c
>index 1dabc26..2ef0709 100644
>--- a/gcc/fortran/trans-intrinsic.c
>+++ b/gcc/fortran/trans-intrinsic.c
>@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr *
>expr)
>   if (arg_expr->rank == 0)
>     {
>       if (arg_expr->ts.type == BT_CLASS)
>-	gfc_add_component_ref (arg_expr, "_data");
>+	gfc_add_data_component (arg_expr);
>       gfc_conv_expr_reference (se, arg_expr);
>     }
>   else
>diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
>index 2a91c35..14dad0f 100644
>--- a/gcc/fortran/trans.c
>+++ b/gcc/fortran/trans.c
>@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block,
>gfc_expr *expr2)
> 
>       final_expr = gfc_copy_expr (expr);
>       gfc_add_vptr_component (final_expr);
>-      gfc_add_component_ref (final_expr, "_final");
>+      gfc_add_final_component (final_expr);
> 
>       elem_size = gfc_copy_expr (expr);
>       gfc_add_vptr_component (elem_size);
>-      gfc_add_component_ref (elem_size, "_size");
>+      gfc_add_size_component (elem_size);
>     }
> 
>   gcc_assert (final_expr->expr_type == EXPR_VARIABLE);

[PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

Hi,

Ok for trunk?

Changes for v4 -> v3:

- rebased
- Use 4 argument levenshtein_distance() to save multiple strlen(typo)
  calls as suggested by dmalcolm

Changes for v2 -> v3:

- rebased

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

gcc/fortran/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
	(gfc_closest_fuzzy_match): New declaration.
	(vec_push): New definition.
	* misc.c (gfc_closest_fuzzy_match): New definition.
	* resolve.c: Include spellcheck.h.
	(lookup_function_fuzzy_find_candidates): New static function.
	(lookup_uop_fuzzy_find_candidates): Likewise.
	(lookup_uop_fuzzy): Likewise.
	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
	(gfc_lookup_function_fuzzy): New definition.
	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
	* interface.c (check_interface0): Likewise.
	(lookup_arg_fuzzy_find_candidates): New static function.
	(lookup_arg_fuzzy ): Likewise.
	(compare_actual_formal): Call lookup_arg_fuzzy.
	* symbol.c: Include spellcheck.h.
	(lookup_symbol_fuzzy_find_candidates): New static function.
	(lookup_symbol_fuzzy): Likewise.
	(gfc_set_default_type): Call lookup_symbol_fuzzy.
	(lookup_component_fuzzy_find_candidates): New static function.
	(lookup_component_fuzzy): Likewise.
	(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/spellcheck-operator.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
	* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
	* gfortran.dg/spellcheck-structure.f90: New testcase.
	* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
   likely to be meaningless.  */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/gfortran.h                             |  12 +++
 gcc/fortran/interface.c                            |  72 +++++++++++++--
 gcc/fortran/misc.c                                 |  41 +++++++++
 gcc/fortran/resolve.c                              | 100 ++++++++++++++++++++-
 gcc/fortran/symbol.c                               |  86 +++++++++++++++++-
 gcc/testsuite/gfortran.dg/spellcheck-operator.f90  |  30 +++++++
 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 |  15 ++++
 .../gfortran.dg/spellcheck-procedure_1.f90         |  41 +++++++++
 .../gfortran.dg/spellcheck-procedure_2.f90         |  35 ++++++++
 gcc/testsuite/gfortran.dg/spellcheck-structure.f90 |  35 ++++++++
 10 files changed, 450 insertions(+), 17 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
 create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0bb71cb..5d43c2d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2682,6 +2682,17 @@ void gfc_done_2 (void);
 
 int get_c_kind (const char *, CInteropKind_t *);
 
+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+  /* {auto,}vec.safe_push () replacement.  Don't ask..  */
+  // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+  optr = XRESIZEVEC (char *, optr, osz + 2);
+  optr[osz] = CONST_CAST (char *, elt);
+  optr[++osz] = NULL;
+}
+
 /* options.c */
 unsigned int gfc_option_lang_mask (void);
 void gfc_init_options_struct (struct gcc_options *);
@@ -3103,6 +3114,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
 
 
 /* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b012de5..bef514c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1694,13 +1694,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 	   || !p->sym->attr.if_source)
 	  && !gfc_fl_struct (p->sym->attr.flavor))
 	{
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
 	  if (p->sym->attr.external)
-	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
-		       p->sym->name, interface_name, &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+			 "; did you mean %qs?",
+			 p->sym->name, interface_name, &p->sym->declared_at,
+			 guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+			 p->sym->name, interface_name, &p->sym->declared_at);
 	  else
-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
-		       "subroutine", p->sym->name, interface_name,
-		      &p->sym->declared_at);
+	    if (guessed)
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine; did you mean %qs?", p->sym->name,
+			interface_name, &p->sym->declared_at, guessed);
+	    else
+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
+			 "subroutine", p->sym->name, interface_name,
+			&p->sym->declared_at);
 	  return 1;
 	}
 
@@ -2684,6 +2698,31 @@ is_procptr_result (gfc_expr *expr)
 }
 
 
+/* Recursively append candidate argument ARG to CANDIDATES.  Store the
+   number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+    vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account.  */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
 /* Given formal and actual argument lists, see if they are compatible.
    If they are compatible, the actual argument list is sorted to
    correspond with the formal list, and elements for missing optional
@@ -2736,8 +2775,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  if (f == NULL)
 	    {
 	      if (where)
-		gfc_error ("Keyword argument %qs at %L is not in "
-			   "the procedure", a->name, &a->expr->where);
+		{
+		  const char *guessed = lookup_arg_fuzzy (a->name, formal);
+		  if (guessed)
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure; did you mean %qs?",
+			       a->name, &a->expr->where, guessed);
+		  else
+		    gfc_error ("Keyword argument %qs at %L is not in "
+			       "the procedure", a->name, &a->expr->where);
+		}
 	      return 0;
 	    }
 
@@ -3436,8 +3483,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
     {
       if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
 	{
-	  gfc_error ("Procedure %qs called at %L is not explicitly declared",
-		     sym->name, where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared"
+		       "; did you mean %qs?",
+		       sym->name, where, guessed);
+	  else
+	    gfc_error ("Procedure %qs called at %L is not explicitly declared",
+		       sym->name, where);
 	  return false;
 	}
       if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 1747ff2..dd17f46 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "gfortran.h"
+#include "spellcheck.h"
 
 
 /* Initialize a typespec to unknown.  */
@@ -280,3 +281,43 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 
   return ISOCBINDING_INVALID;
 }
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+   perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+  /* Determine closest match.  */
+  const char *best = NULL;
+  char **cand = candidates;
+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+  const size_t tl = strlen (typo);
+
+  while (cand && *cand)
+    {
+      edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
+	  strlen (*cand));
+      if (dist < best_distance)
+	{
+	   best_distance = dist;
+	   best = *cand;
+	}
+      cand++;
+    }
+  /* If more than half of the letters were misspelled, the suggestion is
+     likely to be meaningless.  */
+  if (best)
+    {
+      unsigned int cutoff = MAX (tl, strlen (best)) / 2;
+
+      if (best_distance > cutoff)
+	{
+	  XDELETEVEC (candidates);
+	  return NULL;
+	}
+      XDELETEVEC (candidates);
+    }
+  return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 77f8c10..089afa3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2693,6 +2693,43 @@ resolve_specific_f (gfc_expr *expr)
   return true;
 }
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+				       char **&candidates,
+				       size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+  if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+      && sym->n.sym->attr.flavor == FL_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+
+  p = sym->left;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account.  */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (fn, candidates);
+}
+
 
 /* Resolve a procedure call not known to be generic nor specific.  */
 
@@ -2743,8 +2780,15 @@ set_type:
 
       if (ts->type == BT_UNKNOWN)
 	{
-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
-		     sym->name, &expr->where);
+	  const char *guessed
+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+	  if (guessed)
+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &expr->where, guessed);
+	  else
+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
+		       sym->name, &expr->where);
 	  return false;
 	}
       else
@@ -3516,6 +3560,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
 }
 
 
+/* Recursively append candidate UOP to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+				  char **&candidates,
+				  size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (uop == NULL)
+    return;
+
+  /* Not sure how to properly filter here.  Use all for a start.
+     n.uop.op is NULL for empty interface operators (is that legal?) disregard
+     these as i suppose they don't make terribly sense.  */
+
+  if (uop->n.uop->op != NULL)
+    vec_push (candidates, candidates_len, uop->name);
+
+  p = uop->left;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = uop->right;
+  if (p)
+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.  */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+  return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
 
@@ -3714,8 +3798,16 @@ resolve_operator (gfc_expr *e)
 
     case INTRINSIC_USER:
       if (e->value.op.uop->op == NULL)
-	sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
-		 e->value.op.uop->name);
+	{
+	  const char *name = e->value.op.uop->name;
+	  const char *guessed;
+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+	  if (guessed)
+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
+		name, guessed);
+	  else
+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
+	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
 		 e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0ee7dec..776610c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -236,6 +236,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
 }
 
 
+/* Recursively append candidate SYM to CANDIDATES.  Store the number of
+   candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+				     char **&candidates,
+				     size_t &candidates_len)
+{
+  gfc_symtree *p;
+
+  if (sym == NULL)
+    return;
+
+  if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+    vec_push (candidates, candidates_len, sym->name);
+  p = sym->left;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+  p = sym->right;
+  if (p)
+    lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account.  */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+				       candidates_len);
+  return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
 /* Given a pointer to a symbol, set its type according to the first
    letter of its name.  Fails if the letter in question has no default
    type.  */
@@ -254,8 +292,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     {
       if (error_flag && !sym->attr.untyped)
 	{
-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
-		     sym->name, &sym->declared_at);
+	  const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+	  if (guessed)
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+		       "; did you mean %qs?",
+		       sym->name, &sym->declared_at, guessed);
+	  else
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
 
@@ -2233,6 +2277,32 @@ find_union_component (gfc_symbol *un, const char *name,
 }
 
 
+/* Recursively append candidate COMPONENT structures to CANDIDATES.  Store
+   the number of total candidates in CANDIDATES_LEN.  */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+					char **&candidates,
+					size_t &candidates_len)
+{
+  for (gfc_component *p = component; p; p = p->next)
+    vec_push (candidates, candidates_len, p->name);
+}
+
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+  char **candidates = NULL;
+  size_t candidates_len = 0;
+  lookup_component_fuzzy_find_candidates (component, candidates,
+					  candidates_len);
+  return gfc_closest_fuzzy_match (member, candidates);
+}
+
+
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
    not found or the components are private.  If noaccess is set, no access
@@ -2330,8 +2400,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
     }
 
   if (p == NULL && !silent)
-    gfc_error ("%qs at %C is not a member of the %qs structure",
-	       name, sym->name);
+    {
+      const char *guessed = lookup_component_fuzzy (name, sym->components);
+      if (guessed)
+	gfc_error ("%qs at %C is not a member of the %qs structure"
+		   "; did you mean %qs?",
+		   name, sym->name, guessed);
+      else
+	gfc_error ("%qs at %C is not a member of the %qs structure",
+		   name, sym->name);
+    }
 
   /* Component was found; build the ultimate component reference. */
   if (p != NULL && ref)
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_good (iarg1)
+      integer :: something_good
+      integer, intent(in) :: iarg1
+      something_good = iarg1 + 42
+    end function something_good
+end module mymod1
+
+program spellchekc
+  use mymod1
+  implicit none
+
+  interface operator (.mywrong.)
+    module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+  end interface
+
+  interface operator (.mygood.)
+    module procedure something_good
+  end interface
+
+  integer :: i, j, added
+  i = 0
+  j = 0
+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+  subroutine mysub(iarg1)
+    integer :: iarg1
+  end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+  implicit none
+  contains
+    function something_else (iarg1)
+      integer :: something_else
+      integer, intent(in) :: iarg1
+      something_else = iarg1 + 42
+    end function something_else
+    function add_fourtytwo (iarg1)
+      integer :: add_fourtytwo
+      integer, intent(in) :: iarg1
+      add_fourtytwo = iarg1 + 42
+    end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+  implicit none
+  integer :: myadd
+  integer, intent(in) :: iarg1, iarg2
+  myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+  use mymod1, something_good => something_else
+  implicit none
+
+  integer :: myadd, i, j, myvar
+  i = 0
+  j = 0
+
+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+  if (j /= 42) call abort
+  j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+  myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+  if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..a6ea5f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+  implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE with spec list" }
+
+  interface
+    subroutine bark_unless_zero(iarg)
+      implicit none
+      integer, intent(in) :: iarg
+    end subroutine bark_unless_zero
+  end interface
+
+  integer :: i
+  i = 0
+
+  if (i /= 1) call abort
+  call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+!  call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+  subroutine complain_about_zero(iarg)
+    integer, intent(in) :: iarg
+    if (iarg /= 0) call abort
+  end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+  implicit none
+  integer, intent(in) :: iarg
+  if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+   real :: radius
+   integer :: i
+end type type1
+
+type type2
+  integer :: myint
+  type(type1) :: mytype
+end type type2
+
+type type3
+  type(type2) :: type_2
+end type type3
+type type4
+  type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end
-- 
2.8.1

Re: [PATCH] Commentary typo fix for gfc_typenode_for_spec()

[Bernhard Reutner-Fischer]

On Tue, Dec 01, 2015 at 08:00:15AM -0800, Steve Kargl wrote:
> On Tue, Dec 01, 2015 at 01:55:00PM +0100, Bernhard Reutner-Fischer wrote:
> > Regstrapped without regressions, ok for trunk stage3 now / next stage1?
> > 
> > gcc/fortran/ChangeLog
> > 
> > 2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> > 
> > 	* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.
> > 
> 
> Patches to fix typographical errors in comments are pre-approved.

Ack.

This one applied as r237575

Thanks!

Re: [PATCH] Use gfc_add_*_component defines where appropriate

[Paul Richard Thomas]

Hi Bernhard,

Thanks for doing some of this tidying up. The patch is OK to commit on
both trunk and 6-branch. It might be worth going back to 5-branch as
well, if you feel up to it.

Cheers

Paul

On 18 June 2016 at 21:47, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
> Ping.
>
> On December 1, 2015 1:54:58 PM GMT+01:00, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>A couple of places used gfc_add_component_ref(expr, "string") instead
>>of
>>the defines from gfortran.h
>>
>>Regstrapped without regressions, ok for trunk stage3 now / next stage1?
>>
>>gcc/fortran/ChangeLog
>>
>>2015-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>>
>>     * class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
>>        instead of gfc_add_component_ref().
>>       (gfc_get_len_component): Call gfc_add_len_component() instead of
>>        gfc_add_component_ref().
>>        * trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
>>        gfc_add_data_component() instead of gfc_add_component_ref().
>>        * trans.c (gfc_add_finalizer_call): Call
>>        gfc_add_final_component() and gfc_add_size_component() instead
>>        of gfc_add_component_ref.
>>
>>Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
>>---
>> gcc/fortran/class.c           | 4 ++--
>> gcc/fortran/trans-intrinsic.c | 2 +-
>> gcc/fortran/trans.c           | 4 ++--
>> 3 files changed, 5 insertions(+), 5 deletions(-)
>>
>>diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
>>index 8b49ae9..027cb89 100644
>>--- a/gcc/fortran/class.c
>>+++ b/gcc/fortran/class.c
>>@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
>>   int rank = CLASS_DATA (e)->as->rank;
>>   gfc_array_spec *as = CLASS_DATA (e)->as;
>>   gfc_ref *ref = NULL;
>>-  gfc_add_component_ref (e, "_data");
>>+  gfc_add_data_component (e);
>>   e->rank = rank;
>>   for (ref = e->ref; ref; ref = ref->next)
>>     if (!ref->next)
>>@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
>>       ref = ref->next;
>>     }
>>   /* And replace if with a ref to the _len component.  */
>>-  gfc_add_component_ref (ptr, "_len");
>>+  gfc_add_len_component (ptr);
>>   return ptr;
>> }
>>
>>diff --git a/gcc/fortran/trans-intrinsic.c
>>b/gcc/fortran/trans-intrinsic.c
>>index 1dabc26..2ef0709 100644
>>--- a/gcc/fortran/trans-intrinsic.c
>>+++ b/gcc/fortran/trans-intrinsic.c
>>@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr *
>>expr)
>>   if (arg_expr->rank == 0)
>>     {
>>       if (arg_expr->ts.type == BT_CLASS)
>>-      gfc_add_component_ref (arg_expr, "_data");
>>+      gfc_add_data_component (arg_expr);
>>       gfc_conv_expr_reference (se, arg_expr);
>>     }
>>   else
>>diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
>>index 2a91c35..14dad0f 100644
>>--- a/gcc/fortran/trans.c
>>+++ b/gcc/fortran/trans.c
>>@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block,
>>gfc_expr *expr2)
>>
>>       final_expr = gfc_copy_expr (expr);
>>       gfc_add_vptr_component (final_expr);
>>-      gfc_add_component_ref (final_expr, "_final");
>>+      gfc_add_final_component (final_expr);
>>
>>       elem_size = gfc_copy_expr (expr);
>>       gfc_add_vptr_component (elem_size);
>>-      gfc_add_component_ref (elem_size, "_size");
>>+      gfc_add_size_component (elem_size);
>>     }
>>
>>   gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
>
>



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [PATCH] Use gfc_add_*_component defines where appropriate

[Bernhard Reutner-Fischer]

On Sun, Jun 19, 2016 at 11:18:08AM +0200, Paul Richard Thomas wrote:
> Hi Bernhard,
> 
> Thanks for doing some of this tidying up. The patch is OK to commit on
> both trunk and 6-branch. It might be worth going back to 5-branch as
> well, if you feel up to it.

Applied to trunk as r237580 so far.

thanks,

RE: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE

[VandeVondele Joost]

From my point of view, would be really nice to have.

Joost

Ping: [Re: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE]

[Bernhard Reutner-Fischer]

Ping

On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>Hi,
>
>Ok for trunk?
>
>Changes for v4 -> v3:
>
>- rebased
>- Use 4 argument levenshtein_distance() to save multiple strlen(typo)
>  calls as suggested by dmalcolm
>
>Changes for v2 -> v3:
>
>- rebased
>
>Changes for v1 -> v2:
>
>- subroutines using interfaces
>- keyword arguments (named parameters)
>
>Rewrite C++ autovec in plain C.
>Factor out levenshtein distance handling into a commonly used
>gfc_closest_fuzzy_match().
>
>gcc/fortran/ChangeLog
>
>2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>
>	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
>	(gfc_closest_fuzzy_match): New declaration.
>	(vec_push): New definition.
>	* misc.c (gfc_closest_fuzzy_match): New definition.
>	* resolve.c: Include spellcheck.h.
>	(lookup_function_fuzzy_find_candidates): New static function.
>	(lookup_uop_fuzzy_find_candidates): Likewise.
>	(lookup_uop_fuzzy): Likewise.
>	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
>	(gfc_lookup_function_fuzzy): New definition.
>	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
>	* interface.c (check_interface0): Likewise.
>	(lookup_arg_fuzzy_find_candidates): New static function.
>	(lookup_arg_fuzzy ): Likewise.
>	(compare_actual_formal): Call lookup_arg_fuzzy.
>	* symbol.c: Include spellcheck.h.
>	(lookup_symbol_fuzzy_find_candidates): New static function.
>	(lookup_symbol_fuzzy): Likewise.
>	(gfc_set_default_type): Call lookup_symbol_fuzzy.
>	(lookup_component_fuzzy_find_candidates): New static function.
>	(lookup_component_fuzzy): Likewise.
>	(gfc_find_component): Call lookup_component_fuzzy.
>
>gcc/testsuite/ChangeLog
>
>2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>
>	* gfortran.dg/spellcheck-operator.f90: New testcase.
>	* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
>	* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
>	* gfortran.dg/spellcheck-structure.f90: New testcase.
>	* gfortran.dg/spellcheck-parameter.f90: New testcase.
>
>---
>
>David Malcolm's nice Levenshtein distance spelling check helpers
>were used in some parts of other frontends. This proposed patch adds
>some spelling corrections to the fortran frontend.
>
>Suggestions are printed if we can find a suitable name, currently
>perusing a very simple cutoff factor:
>/* If more than half of the letters were misspelled, the suggestion is
>   likely to be meaningless.  */
>cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
>which effectively skips names with less than 4 characters.
>For e.g. structures, one could try to be much smarter in an attempt to
>also provide suggestions for single-letter members/components.
>
>This patch covers (at least partly):
>- user-defined operators
>- structures (types and their components)
>- functions
>- symbols (variables)
>
>If anybody has a testcase where a spelling-suggestion would make sense
>then please pass it along so we maybe can add support for GCC-7.
>
>Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
>---
> gcc/fortran/gfortran.h                             |  12 +++
>gcc/fortran/interface.c                            |  72
>+++++++++++++--
> gcc/fortran/misc.c                                 |  41 +++++++++
>gcc/fortran/resolve.c                              | 100
>++++++++++++++++++++-
>gcc/fortran/symbol.c                               |  86
>+++++++++++++++++-
> gcc/testsuite/gfortran.dg/spellcheck-operator.f90  |  30 +++++++
> gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 |  15 ++++
> .../gfortran.dg/spellcheck-procedure_1.f90         |  41 +++++++++
> .../gfortran.dg/spellcheck-procedure_2.f90         |  35 ++++++++
> gcc/testsuite/gfortran.dg/spellcheck-structure.f90 |  35 ++++++++
> 10 files changed, 450 insertions(+), 17 deletions(-)
> create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
> create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
>create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
>create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
> create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90
>
>diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
>index 0bb71cb..5d43c2d 100644
>--- a/gcc/fortran/gfortran.h
>+++ b/gcc/fortran/gfortran.h
>@@ -2682,6 +2682,17 @@ void gfc_done_2 (void);
> 
> int get_c_kind (const char *, CInteropKind_t *);
> 
>+const char *gfc_closest_fuzzy_match (const char *, char **);
>+static inline void
>+vec_push (char **&optr, size_t &osz, const char *elt)
>+{
>+  /* {auto,}vec.safe_push () replacement.  Don't ask..  */
>+  // if (strlen (elt) < 4) return; premature optimization: eliminated
>by cutoff
>+  optr = XRESIZEVEC (char *, optr, osz + 2);
>+  optr[osz] = CONST_CAST (char *, elt);
>+  optr[++osz] = NULL;
>+}
>+
> /* options.c */
> unsigned int gfc_option_lang_mask (void);
> void gfc_init_options_struct (struct gcc_options *);
>@@ -3103,6 +3114,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
> bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
> bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
> extern int gfc_do_concurrent_flag;
>+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
> 
> 
> /* array.c */
>diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
>index b012de5..bef514c 100644
>--- a/gcc/fortran/interface.c
>+++ b/gcc/fortran/interface.c
>@@ -1694,13 +1694,27 @@ check_interface0 (gfc_interface *p, const char
>*interface_name)
> 	   || !p->sym->attr.if_source)
> 	  && !gfc_fl_struct (p->sym->attr.flavor))
> 	{
>+	  const char *guessed
>+	    = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
>+
> 	  if (p->sym->attr.external)
>-	    gfc_error ("Procedure %qs in %s at %L has no explicit interface",
>-		       p->sym->name, interface_name, &p->sym->declared_at);
>+	    if (guessed)
>+	      gfc_error ("Procedure %qs in %s at %L has no explicit
>interface"
>+			 "; did you mean %qs?",
>+			 p->sym->name, interface_name, &p->sym->declared_at,
>+			 guessed);
>+	    else
>+	      gfc_error ("Procedure %qs in %s at %L has no explicit
>interface",
>+			 p->sym->name, interface_name, &p->sym->declared_at);
> 	  else
>-	    gfc_error ("Procedure %qs in %s at %L is neither function nor "
>-		       "subroutine", p->sym->name, interface_name,
>-		      &p->sym->declared_at);
>+	    if (guessed)
>+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
>+			 "subroutine; did you mean %qs?", p->sym->name,
>+			interface_name, &p->sym->declared_at, guessed);
>+	    else
>+	      gfc_error ("Procedure %qs in %s at %L is neither function nor "
>+			 "subroutine", p->sym->name, interface_name,
>+			&p->sym->declared_at);
> 	  return 1;
> 	}
> 
>@@ -2684,6 +2698,31 @@ is_procptr_result (gfc_expr *expr)
> }
> 
> 
>+/* Recursively append candidate argument ARG to CANDIDATES.  Store the
>+   number of total candidates in CANDIDATES_LEN.  */
>+
>+static void
>+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
>+				  char **&candidates,
>+				  size_t &candidates_len)
>+{
>+  for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
>+    vec_push (candidates, candidates_len, p->sym->name);
>+}
>+
>+
>+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into
>account.  */
>+
>+static const char*
>+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
>+{
>+  char **candidates = NULL;
>+  size_t candidates_len = 0;
>+  lookup_arg_fuzzy_find_candidates (arguments, candidates,
>candidates_len);
>+  return gfc_closest_fuzzy_match (arg, candidates);
>+}
>+
>+
> /* Given formal and actual argument lists, see if they are compatible.
>    If they are compatible, the actual argument list is sorted to
>    correspond with the formal list, and elements for missing optional
>@@ -2736,8 +2775,16 @@ compare_actual_formal (gfc_actual_arglist **ap,
>gfc_formal_arglist *formal,
> 	  if (f == NULL)
> 	    {
> 	      if (where)
>-		gfc_error ("Keyword argument %qs at %L is not in "
>-			   "the procedure", a->name, &a->expr->where);
>+		{
>+		  const char *guessed = lookup_arg_fuzzy (a->name, formal);
>+		  if (guessed)
>+		    gfc_error ("Keyword argument %qs at %L is not in "
>+			       "the procedure; did you mean %qs?",
>+			       a->name, &a->expr->where, guessed);
>+		  else
>+		    gfc_error ("Keyword argument %qs at %L is not in "
>+			       "the procedure", a->name, &a->expr->where);
>+		}
> 	      return 0;
> 	    }
> 
>@@ -3436,8 +3483,15 @@ gfc_procedure_use (gfc_symbol *sym,
>gfc_actual_arglist **ap, locus *where)
>     {
>if (sym->ns->has_implicit_none_export && sym->attr.proc ==
>PROC_UNKNOWN)
> 	{
>-	  gfc_error ("Procedure %qs called at %L is not explicitly declared",
>-		     sym->name, where);
>+	  const char *guessed
>+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
>+	  if (guessed)
>+	    gfc_error ("Procedure %qs called at %L is not explicitly
>declared"
>+		       "; did you mean %qs?",
>+		       sym->name, where, guessed);
>+	  else
>+	    gfc_error ("Procedure %qs called at %L is not explicitly
>declared",
>+		       sym->name, where);
> 	  return false;
> 	}
>       if (warn_implicit_interface)
>diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
>index 1747ff2..dd17f46 100644
>--- a/gcc/fortran/misc.c
>+++ b/gcc/fortran/misc.c
>@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3.  If not see
> #include "system.h"
> #include "coretypes.h"
> #include "gfortran.h"
>+#include "spellcheck.h"
> 
> 
> /* Initialize a typespec to unknown.  */
>@@ -280,3 +281,43 @@ get_c_kind(const char *c_kind_name, CInteropKind_t
>kinds_table[])
> 
>   return ISOCBINDING_INVALID;
> }
>+
>+
>+/* For a given name TYPO, determine the best candidate from CANDIDATES
>+   perusing Levenshtein distance.  Frees CANDIDATES before returning. 
>*/
>+
>+const char *
>+gfc_closest_fuzzy_match (const char *typo, char **candidates)
>+{
>+  /* Determine closest match.  */
>+  const char *best = NULL;
>+  char **cand = candidates;
>+  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
>+  const size_t tl = strlen (typo);
>+
>+  while (cand && *cand)
>+    {
>+      edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
>+	  strlen (*cand));
>+      if (dist < best_distance)
>+	{
>+	   best_distance = dist;
>+	   best = *cand;
>+	}
>+      cand++;
>+    }
>+  /* If more than half of the letters were misspelled, the suggestion
>is
>+     likely to be meaningless.  */
>+  if (best)
>+    {
>+      unsigned int cutoff = MAX (tl, strlen (best)) / 2;
>+
>+      if (best_distance > cutoff)
>+	{
>+	  XDELETEVEC (candidates);
>+	  return NULL;
>+	}
>+      XDELETEVEC (candidates);
>+    }
>+  return best;
>+}
>diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
>index 77f8c10..089afa3 100644
>--- a/gcc/fortran/resolve.c
>+++ b/gcc/fortran/resolve.c
>@@ -2693,6 +2693,43 @@ resolve_specific_f (gfc_expr *expr)
>   return true;
> }
> 
>+/* Recursively append candidate SYM to CANDIDATES.  Store the number
>of
>+   candidates in CANDIDATES_LEN.  */
>+
>+static void
>+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
>+				       char **&candidates,
>+				       size_t &candidates_len)
>+{
>+  gfc_symtree *p;
>+
>+  if (sym == NULL)
>+    return;
>+  if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
>+      && sym->n.sym->attr.flavor == FL_PROCEDURE)
>+    vec_push (candidates, candidates_len, sym->name);
>+
>+  p = sym->left;
>+  if (p)
>+    lookup_function_fuzzy_find_candidates (p, candidates,
>candidates_len);
>+
>+  p = sym->right;
>+  if (p)
>+    lookup_function_fuzzy_find_candidates (p, candidates,
>candidates_len);
>+}
>+
>+
>+/* Lookup function FN fuzzily, taking names in SYMROOT into account. 
>*/
>+
>+const char*
>+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
>+{
>+  char **candidates = NULL;
>+  size_t candidates_len = 0;
>+  lookup_function_fuzzy_find_candidates (symroot, candidates,
>candidates_len);
>+  return gfc_closest_fuzzy_match (fn, candidates);
>+}
>+
> 
> /* Resolve a procedure call not known to be generic nor specific.  */
> 
>@@ -2743,8 +2780,15 @@ set_type:
> 
>       if (ts->type == BT_UNKNOWN)
> 	{
>-	  gfc_error ("Function %qs at %L has no IMPLICIT type",
>-		     sym->name, &expr->where);
>+	  const char *guessed
>+	    = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
>+	  if (guessed)
>+	    gfc_error ("Function %qs at %L has no IMPLICIT type"
>+		       "; did you mean %qs?",
>+		       sym->name, &expr->where, guessed);
>+	  else
>+	    gfc_error ("Function %qs at %L has no IMPLICIT type",
>+		       sym->name, &expr->where);
> 	  return false;
> 	}
>       else
>@@ -3516,6 +3560,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
> }
> 
> 
>+/* Recursively append candidate UOP to CANDIDATES.  Store the number
>of
>+   candidates in CANDIDATES_LEN.  */
>+static void
>+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
>+				  char **&candidates,
>+				  size_t &candidates_len)
>+{
>+  gfc_symtree *p;
>+
>+  if (uop == NULL)
>+    return;
>+
>+  /* Not sure how to properly filter here.  Use all for a start.
>+     n.uop.op is NULL for empty interface operators (is that legal?)
>disregard
>+     these as i suppose they don't make terribly sense.  */
>+
>+  if (uop->n.uop->op != NULL)
>+    vec_push (candidates, candidates_len, uop->name);
>+
>+  p = uop->left;
>+  if (p)
>+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
>+
>+  p = uop->right;
>+  if (p)
>+    lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
>+}
>+
>+/* Lookup user-operator OP fuzzily, taking names in UOP into account. 
>*/
>+
>+static const char*
>+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
>+{
>+  char **candidates = NULL;
>+  size_t candidates_len = 0;
>+  lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
>+  return gfc_closest_fuzzy_match (op, candidates);
>+}
>+
>+
>/* Resolve an operator expression node.  This can involve replacing the
>    operation with a user defined function call.  */
> 
>@@ -3714,8 +3798,16 @@ resolve_operator (gfc_expr *e)
> 
>     case INTRINSIC_USER:
>       if (e->value.op.uop->op == NULL)
>-	sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
>-		 e->value.op.uop->name);
>+	{
>+	  const char *name = e->value.op.uop->name;
>+	  const char *guessed;
>+	  guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
>+	  if (guessed)
>+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean
>'%s'?"),
>+		name, guessed);
>+	  else
>+	    sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
>+	}
>       else if (op2 == NULL)
> 	sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
> 		 e->value.op.uop->name, gfc_typename (&op1->ts));
>diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
>index 0ee7dec..776610c 100644
>--- a/gcc/fortran/symbol.c
>+++ b/gcc/fortran/symbol.c
>@@ -236,6 +236,44 @@ gfc_get_default_type (const char *name,
>gfc_namespace *ns)
> }
> 
> 
>+/* Recursively append candidate SYM to CANDIDATES.  Store the number
>of
>+   candidates in CANDIDATES_LEN.  */
>+
>+static void
>+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
>+				     char **&candidates,
>+				     size_t &candidates_len)
>+{
>+  gfc_symtree *p;
>+
>+  if (sym == NULL)
>+    return;
>+
>+  if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type !=
>BT_PROCEDURE)
>+    vec_push (candidates, candidates_len, sym->name);
>+  p = sym->left;
>+  if (p)
>+    lookup_symbol_fuzzy_find_candidates (p, candidates,
>candidates_len);
>+
>+  p = sym->right;
>+  if (p)
>+    lookup_symbol_fuzzy_find_candidates (p, candidates,
>candidates_len);
>+}
>+
>+
>+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into
>account.  */
>+
>+static const char*
>+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
>+{
>+  char **candidates = NULL;
>+  size_t candidates_len = 0;
>+  lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root,
>candidates,
>+				       candidates_len);
>+  return gfc_closest_fuzzy_match (sym_name, candidates);
>+}
>+
>+
> /* Given a pointer to a symbol, set its type according to the first
>    letter of its name.  Fails if the letter in question has no default
>    type.  */
>@@ -254,8 +292,14 @@ gfc_set_default_type (gfc_symbol *sym, int
>error_flag, gfc_namespace *ns)
>     {
>       if (error_flag && !sym->attr.untyped)
> 	{
>-	  gfc_error ("Symbol %qs at %L has no IMPLICIT type",
>-		     sym->name, &sym->declared_at);
>+	  const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
>+	  if (guessed)
>+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type"
>+		       "; did you mean %qs?",
>+		       sym->name, &sym->declared_at, guessed);
>+	  else
>+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
>+		       sym->name, &sym->declared_at);
> 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
> 	}
> 
>@@ -2233,6 +2277,32 @@ find_union_component (gfc_symbol *un, const char
>*name,
> }
> 
> 
>+/* Recursively append candidate COMPONENT structures to CANDIDATES. 
>Store
>+   the number of total candidates in CANDIDATES_LEN.  */
>+
>+static void
>+lookup_component_fuzzy_find_candidates (gfc_component *component,
>+					char **&candidates,
>+					size_t &candidates_len)
>+{
>+  for (gfc_component *p = component; p; p = p->next)
>+    vec_push (candidates, candidates_len, p->name);
>+}
>+
>+
>+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into
>account.  */
>+
>+static const char*
>+lookup_component_fuzzy (const char *member, gfc_component *component)
>+{
>+  char **candidates = NULL;
>+  size_t candidates_len = 0;
>+  lookup_component_fuzzy_find_candidates (component, candidates,
>+					  candidates_len);
>+  return gfc_closest_fuzzy_match (member, candidates);
>+}
>+
>+
> /* Given a derived type node and a component name, try to locate the
>    component structure.  Returns the NULL pointer if the component is
>not found or the components are private.  If noaccess is set, no access
>@@ -2330,8 +2400,16 @@ gfc_find_component (gfc_symbol *sym, const char
>*name,
>     }
> 
>   if (p == NULL && !silent)
>-    gfc_error ("%qs at %C is not a member of the %qs structure",
>-	       name, sym->name);
>+    {
>+      const char *guessed = lookup_component_fuzzy (name,
>sym->components);
>+      if (guessed)
>+	gfc_error ("%qs at %C is not a member of the %qs structure"
>+		   "; did you mean %qs?",
>+		   name, sym->name, guessed);
>+      else
>+	gfc_error ("%qs at %C is not a member of the %qs structure",
>+		   name, sym->name);
>+    }
> 
>   /* Component was found; build the ultimate component reference. */
>   if (p != NULL && ref)
>diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
>b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
>new file mode 100644
>index 0000000..810a770
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
>@@ -0,0 +1,30 @@
>+! { dg-do compile }
>+! test levenshtein based spelling suggestions
>+
>+module mymod1
>+  implicit none
>+  contains
>+    function something_good (iarg1)
>+      integer :: something_good
>+      integer, intent(in) :: iarg1
>+      something_good = iarg1 + 42
>+    end function something_good
>+end module mymod1
>+
>+program spellchekc
>+  use mymod1
>+  implicit none
>+
>+  interface operator (.mywrong.)
>+    module procedure something_wring ! { dg-error "Procedure
>.something_wring. in operator interface .mywrong. at .1. is neither
>function nor subroutine; did you mean .something_good.\\?|User operator
>procedure .something_wring. at .1. must be a FUNCTION" }
>+  end interface
>+
>+  interface operator (.mygood.)
>+    module procedure something_good
>+  end interface
>+
>+  integer :: i, j, added
>+  i = 0
>+  j = 0
>+  added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.;
>did you mean .mygood.\\?" }
>+end program spellchekc
>diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
>b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
>new file mode 100644
>index 0000000..715c5ab
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
>@@ -0,0 +1,15 @@
>+! { dg-do compile }
>+! Contributed by Joost VandeVondele
>+! test levenshtein based spelling suggestions for keyword arguments
>+
>+module test
>+contains
>+  subroutine mysub(iarg1)
>+    integer :: iarg1
>+  end subroutine
>+end module
>+
>+use test
>+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not
>in the procedure; did you mean .iarg1.\\?" }
>+
>+end
>diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
>b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
>new file mode 100644
>index 0000000..3b7f716
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
>@@ -0,0 +1,41 @@
>+! { dg-do compile }
>+! test levenshtein based spelling suggestions
>+
>+module mymod1
>+  implicit none
>+  contains
>+    function something_else (iarg1)
>+      integer :: something_else
>+      integer, intent(in) :: iarg1
>+      something_else = iarg1 + 42
>+    end function something_else
>+    function add_fourtytwo (iarg1)
>+      integer :: add_fourtytwo
>+      integer, intent(in) :: iarg1
>+      add_fourtytwo = iarg1 + 42
>+    end function add_fourtytwo
>+end module mymod1
>+
>+function myadd(iarg1, iarg2)
>+  implicit none
>+  integer :: myadd
>+  integer, intent(in) :: iarg1, iarg2
>+  myadd = iarg1 + iarg2
>+end function myadd
>+
>+program spellchekc
>+  use mymod1, something_good => something_else
>+  implicit none
>+
>+  integer :: myadd, i, j, myvar
>+  i = 0
>+  j = 0
>+
>+  j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean
>.something_good.\\?" }
>+  j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean
>.myadd.\\?" }
>+  if (j /= 42) call abort
>+  j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean
>.add_fourtytwo.\\?" }
>+  myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean
>.myvar.\\?" }
>+  if (j /= 42 * 2) call abort
>+
>+end program spellchekc
>diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
>b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
>new file mode 100644
>index 0000000..a6ea5f9
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
>@@ -0,0 +1,35 @@
>+! { dg-do compile }
>+! test levenshtein based spelling suggestions
>+
>+
>+program spellchekc
>+  implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE
>with spec list" }
>+
>+  interface
>+    subroutine bark_unless_zero(iarg)
>+      implicit none
>+      integer, intent(in) :: iarg
>+    end subroutine bark_unless_zero
>+  end interface
>+
>+  integer :: i
>+  i = 0
>+
>+  if (i /= 1) call abort
>+  call bark_unless_0(i) ! { dg-error "not explicitly declared; did you
>mean .bark_unless_zero.\\?" }
>+!  call complain_about_0(i) ! { -dg-error "not explicitly declared;
>did you mean .complain_about_zero.\\?" }
>+
>+contains
>+! We cannot reliably see this ATM, would need an unambiguous bit
>somewhere
>+  subroutine complain_about_zero(iarg)
>+    integer, intent(in) :: iarg
>+    if (iarg /= 0) call abort
>+  end subroutine complain_about_zero
>+
>+end program spellchekc
>+
>+subroutine bark_unless_zero(iarg)
>+  implicit none
>+  integer, intent(in) :: iarg
>+  if (iarg /= 0) call abort
>+end subroutine bark_unless_zero
>diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
>b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
>new file mode 100644
>index 0000000..929e05f
>--- /dev/null
>+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
>@@ -0,0 +1,35 @@
>+! { dg-do compile }
>+! test levenshtein based spelling suggestions
>+implicit none
>+
>+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
>+type type1
>+   real :: radius
>+   integer :: i
>+end type type1
>+
>+type type2
>+  integer :: myint
>+  type(type1) :: mytype
>+end type type2
>+
>+type type3
>+  type(type2) :: type_2
>+end type type3
>+type type4
>+  type(type3) :: type_3
>+end type type4
>+
>+type(type1) :: t1
>+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the
>.type1. structure; did you mean .radius.\\?" }
>+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1.
>structure" }
>+type(type2) :: t2
>+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of
>the .type2. structure; did you mean .mytype.\\?" }
>+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member
>of the .type1. structure; did you mean .radius.\\?" }
>+type(type4) :: t4
>+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is
>not a member of the .type1. structure; did you mean .radius.\\?" }
>+
>+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
>+integer :: iarg1
>+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type;
>did you mean .iarg1.\\?" }
>+end

Re: Ping: [Re: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE]

[Jerry DeLisle]

On 07/03/2016 03:42 PM, Bernhard Reutner-Fischer wrote:
> Ping
>
> On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>> Hi,
>>
>> Ok for trunk?

I think this is OK, can we get one other gfortran person to concur?

Jerry

Re: Ping: [Re: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE]

[Janne Blomqvist]

Ok for my part too.

On Mon, Jul 4, 2016 at 6:29 AM, Jerry DeLisle <jvdelisle@charter.net> wrote:
> On 07/03/2016 03:42 PM, Bernhard Reutner-Fischer wrote:
>>
>> Ping
>>
>> On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer
>> <rep.dot.nop@gmail.com> wrote:
>>>
>>> Hi,
>>>
>>> Ok for trunk?
>
>
> I think this is OK, can we get one other gfortran person to concur?
>
> Jerry



-- 
Janne Blomqvist

Re: Ping: [Re: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE]

[Bernhard Reutner-Fischer]

On Mon, Jul 04, 2016 at 08:03:21AM +0300, Janne Blomqvist wrote:
> Ok for my part too.
> 
> On Mon, Jul 4, 2016 at 6:29 AM, Jerry DeLisle <jvdelisle@charter.net> wrote:
> > On 07/03/2016 03:42 PM, Bernhard Reutner-Fischer wrote:
> >>
> >> Ping
> >>
> >> On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer
> >> <rep.dot.nop@gmail.com> wrote:
> >>>
> >>> Hi,
> >>>
> >>> Ok for trunk?
> >
> >
> > I think this is OK, can we get one other gfortran person to concur?

Finally committed as r253877 after another round of boostrapping and
regtesting on x86_64-foo-linux.

thanks,

Re: [PATCH, fortran, v4] Use Levenshtein spelling suggestions in Fortran FE

[Bernhard Reutner-Fischer]

[forgot to CC gcc-patches]

On Sat, Jun 18, 2016 at 09:58:47PM +0200, Bernhard Reutner-Fischer wrote:
> Hi,
> 
> Ok for trunk?

This was ACKed about a year ago by Janne and Jerry and since there were
no objections in the meantime i've installed this first step towards
providing spelling suggestions in the fortran FE as r253877.

cheers,
> 
> Changes for v4 -> v3:
> 
> - rebased
> - Use 4 argument levenshtein_distance() to save multiple strlen(typo)
>   calls as suggested by dmalcolm
> 
> Changes for v2 -> v3:
> 
> - rebased
> 
> Changes for v1 -> v2:
> 
> - subroutines using interfaces
> - keyword arguments (named parameters)
> 
> Rewrite C++ autovec in plain C.
> Factor out levenshtein distance handling into a commonly used
> gfc_closest_fuzzy_match().
> 
> gcc/fortran/ChangeLog
> 
> 2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
> 	(gfc_closest_fuzzy_match): New declaration.
> 	(vec_push): New definition.
> 	* misc.c (gfc_closest_fuzzy_match): New definition.
> 	* resolve.c: Include spellcheck.h.
> 	(lookup_function_fuzzy_find_candidates): New static function.
> 	(lookup_uop_fuzzy_find_candidates): Likewise.
> 	(lookup_uop_fuzzy): Likewise.
> 	(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
> 	(gfc_lookup_function_fuzzy): New definition.
> 	(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
> 	* interface.c (check_interface0): Likewise.
> 	(lookup_arg_fuzzy_find_candidates): New static function.
> 	(lookup_arg_fuzzy ): Likewise.
> 	(compare_actual_formal): Call lookup_arg_fuzzy.
> 	* symbol.c: Include spellcheck.h.
> 	(lookup_symbol_fuzzy_find_candidates): New static function.
> 	(lookup_symbol_fuzzy): Likewise.
> 	(gfc_set_default_type): Call lookup_symbol_fuzzy.
> 	(lookup_component_fuzzy_find_candidates): New static function.
> 	(lookup_component_fuzzy): Likewise.
> 	(gfc_find_component): Call lookup_component_fuzzy.
> 
> gcc/testsuite/ChangeLog
> 
> 2015-12-27  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* gfortran.dg/spellcheck-operator.f90: New testcase.
> 	* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
> 	* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
> 	* gfortran.dg/spellcheck-structure.f90: New testcase.
> 	* gfortran.dg/spellcheck-parameter.f90: New testcase.
> 
> ---
> 
> David Malcolm's nice Levenshtein distance spelling check helpers
> were used in some parts of other frontends. This proposed patch adds
> some spelling corrections to the fortran frontend.
> 
> Suggestions are printed if we can find a suitable name, currently
> perusing a very simple cutoff factor:
> /* If more than half of the letters were misspelled, the suggestion is
>    likely to be meaningless.  */
> cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
> which effectively skips names with less than 4 characters.
> For e.g. structures, one could try to be much smarter in an attempt to
> also provide suggestions for single-letter members/components.
> 
> This patch covers (at least partly):
> - user-defined operators
> - structures (types and their components)
> - functions
> - symbols (variables)
> 
> If anybody has a testcase where a spelling-suggestion would make sense
> then please pass it along so we maybe can add support for GCC-7.

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On Sat, Jun 18, 2016 at 09:46:17PM +0200, Bernhard Reutner-Fischer wrote:
> On December 3, 2015 10:46:09 AM GMT+01:00, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
> >On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer
> ><rep.dot.nop@gmail.com> wrote:
> >> On 1 December 2015 at 15:52, Janne Blomqvist
> ><blomqvist.janne@gmail.com> wrote:
> >>> On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
> >>> <rep.dot.nop@gmail.com> wrote:
> >>>> These three function used a hardcoded buffer of 100 but would be
> >better
> >>>> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length
> >of a
> >>>> name in any of our supported standards (63 as of f2003 ff.).
> >>>
> >>> Please use xasprintf() instead (and free the result, or course). One
> >>> of my backburner projects is to get rid of these static symbol
> >>> buffers, and use dynamic buffers (or the symbol table) instead. We
> >>> IIRC already have some ugly hacks by using hashing to get around
> >>> GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
> >>> make the situation worse per se, but if you're going to fix it, lets
> >>> do it properly.
> >>
> >> I see.
> >>
> >> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
> >> "^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
> >> 142
> >> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
> >> 32
> >
> >Yes, that's why it's on the TODO-list rather than on the DONE-list. :)
> >
> >> What about memory fragmentation when switching to heap-based
> >allocation?
> >> Or is there consensus that these are in the noise compared to other
> >> parts of the compiler?
> >
> >Heap fragmentation is an issue, yes. I'm not sure it's that
> >performance-critical, but I don't think there is any consensus. I just
> >want to avoid ugly hacks like symbol hashing to fit within some fixed
> >buffer. Perhaps an good compromise would be something like std::string
> >with small string optimization, but as you have seen there is some
> >resistance to C++. But this is more relevant for mangled symbols, so
> >GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
> >few of them left. So, well, if you're sure that mangled symbols are
> >never copied into the buffers your patch modifies, please consider
> >your original patch Ok as well. Whichever you prefer.
> >
> >Performance-wise I think a bigger benefit would be to use the symbol
> >table more and then e.g. be able to do pointer comparisons rather than
> >strcmp(). But that is certainly much more work.
> 
> Hm, worth a look indeed since that would certainly be a step in the right direction.

Installed the initial patch as intermediate step as r253881 for now.

thanks,
> 
> >
> >> BTW:
> >> $ git grep APO
> >> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",
> >NULL };
> >> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",
> >NULL };
> >
> >? What are you saying?
> 
> delim is duplicated, we should remove one instance.
> thanks,
> 

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On 19 October 2017 10:03:06 CEST, Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>On Sat, Jun 18, 2016 at 09:46:17PM +0200, Bernhard Reutner-Fischer
>wrote:
>> On December 3, 2015 10:46:09 AM GMT+01:00, Janne Blomqvist
><blomqvist.janne@gmail.com> wrote:
>> >On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer
>> ><rep.dot.nop@gmail.com> wrote:
>> >> On 1 December 2015 at 15:52, Janne Blomqvist
>> ><blomqvist.janne@gmail.com> wrote:
>> >>> On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer
>> >>> <rep.dot.nop@gmail.com> wrote:
>> >>>> These three function used a hardcoded buffer of 100 but would be
>> >better
>> >>>> off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum
>length
>> >of a
>> >>>> name in any of our supported standards (63 as of f2003 ff.).
>> >>>
>> >>> Please use xasprintf() instead (and free the result, or course).
>One
>> >>> of my backburner projects is to get rid of these static symbol
>> >>> buffers, and use dynamic buffers (or the symbol table) instead.
>We
>> >>> IIRC already have some ugly hacks by using hashing to get around
>> >>> GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch
>doesn't
>> >>> make the situation worse per se, but if you're going to fix it,
>lets
>> >>> do it properly.
>> >>
>> >> I see.
>> >>
>> >> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
>> >> "^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc
>-l
>> >> 142
>> >> /scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc
>-l
>> >> 32
>> >
>> >Yes, that's why it's on the TODO-list rather than on the DONE-list.
>:)
>> >
>> >> What about memory fragmentation when switching to heap-based
>> >allocation?
>> >> Or is there consensus that these are in the noise compared to
>other
>> >> parts of the compiler?
>> >
>> >Heap fragmentation is an issue, yes. I'm not sure it's that
>> >performance-critical, but I don't think there is any consensus. I
>just
>> >want to avoid ugly hacks like symbol hashing to fit within some
>fixed
>> >buffer. Perhaps an good compromise would be something like
>std::string
>> >with small string optimization, but as you have seen there is some
>> >resistance to C++. But this is more relevant for mangled symbols, so
>> >GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
>> >few of them left. So, well, if you're sure that mangled symbols are
>> >never copied into the buffers your patch modifies, please consider
>> >your original patch Ok as well. Whichever you prefer.
>> >
>> >Performance-wise I think a bigger benefit would be to use the symbol
>> >table more and then e.g. be able to do pointer comparisons rather
>than
>> >strcmp(). But that is certainly much more work.
>> 
>> Hm, worth a look indeed since that would certainly be a step in the
>right direction.
>
>Installed the initial patch as intermediate step as r253881 for now.

JFYI I'm contemplating to move the stack-based allocations to heap-based ones now, starting with gfc_match_name and gradually moving to pointer comparisons with the stringpool based identifiers. I'll strive to suggest something for discussion in smallish steps when it's ready.

Cheers,
>
>thanks,
>> 
>> >
>> >> BTW:
>> >> $ git grep APO
>> >> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE",
>"NONE",
>> >NULL };
>> >> io.c:  static const char *delim[] = { "APOSTROPHE", "QUOTE",
>"NONE",
>> >NULL };
>> >
>> >? What are you saying?
>> 
>> delim is duplicated, we should remove one instance.
>> thanks,
>> 

Re: [PATCH] Derive interface buffers from max name length

[Thomas Koenig]

Hi Bernhard,

 > JFYI I'm contemplating to move the stack-based allocations
 > to heap-based ones now, starting with gfc_match_name and
 > gradually moving to pointer comparisons with the stringpool based
 > identifiers. I'll strive to suggest something for discussion in
 > smallish steps when it's ready.

What is the driver behind this change? Code clarity? Speed?


Regards

	Thomas

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On 21 October 2017 at 17:18, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Bernhard,
>
>> JFYI I'm contemplating to move the stack-based allocations
>> to heap-based ones now, starting with gfc_match_name and
>> gradually moving to pointer comparisons with the stringpool based
>> identifiers. I'll strive to suggest something for discussion in
>> smallish steps when it's ready.
>
> What is the driver behind this change? Code clarity? Speed?

The idea is to replace string-comparison with pointer comparison which
should help speed.
See Janne's suggestion to do this earlier in this thread.
It's more or less janitorial work. IIRC the C family of FEs switched
to this scheme many years ago for good measure and nobody had time to
take care of the fortran FE. At least that's my understanding.

thanks,

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On Sat, Oct 21, 2017 at 08:11:24PM +0200, Bernhard Reutner-Fischer wrote:

> >> JFYI I'm contemplating to move the stack-based allocations
> >> to heap-based ones now, starting with gfc_match_name and
> >> gradually moving to pointer comparisons with the stringpool based
> >> identifiers. I'll strive to suggest something for discussion in
> >> smallish steps when it's ready.

So i'm mostly through this.

One thing that is still missing is to hash keywords like basic types,
"ppr@" (decl.c), "kind", "null", module_natures (intrinsic /
non_intrinsic), the "ieee_" stuff in expr.c, things like inquiry_func_f95
and inquiry_func_f2003 in expr.c, intrinsic operators, c_interop_kinds_table
etc, etc.

I initially thought about just hashing just all minit()ed data and maybe
i'll end up doing this anyway. We will then have to add a helper in the
initialization to setup the stringpool nodes. It would be easiest to
just do all (or most) of the minit()ed data and integral types in one
place unless you prefer to push this down to appropriate places where
applicable, like add e.g. the basic type nodes and the "kind" node
in gfc_init_types. Whatever is deemed to be more appropriate. WDYT?

thanks

Re: [PATCH] Derive interface buffers from max name length

[Bernhard Reutner-Fischer]

On Tue, 31 Oct 2017 at 21:35, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
>
> On Sat, Oct 21, 2017 at 08:11:24PM +0200, Bernhard Reutner-Fischer wrote:
>
> > >> JFYI I'm contemplating to move the stack-based allocations
> > >> to heap-based ones now, starting with gfc_match_name and
> > >> gradually moving to pointer comparisons with the stringpool based
> > >> identifiers. I'll strive to suggest something for discussion in
> > >> smallish steps when it's ready.
>
> So i'm mostly through this.
>
> One thing that is still missing is to hash keywords like basic types,
> "ppr@" (decl.c), "kind", "null", module_natures (intrinsic /
> non_intrinsic), the "ieee_" stuff in expr.c, things like inquiry_func_f95
> and inquiry_func_f2003 in expr.c, intrinsic operators, c_interop_kinds_table
> etc, etc.

FWIW:
I've saved away a checkpoint that regtests cleanly (against
trunk@264039 from yesterday):
https://gcc.gnu.org/git/?p=gcc.git;a=shortlog;h=refs/heads/aldot/fortran-fe-stringpool

Please disregard the first 4 patches, they do not belong to this
series and will be dropped.

There are some more places left to switch.
Not yet included is a patch to switch the symtree to a hash_map, which
i think is what we may ultimately want to do.
AFAIR doing so was running into GC issues which i did not tackle yet.

cheers,

> I initially thought about just hashing just all minit()ed data and maybe
> i'll end up doing this anyway. We will then have to add a helper in the
> initialization to setup the stringpool nodes. It would be easiest to
> just do all (or most) of the minit()ed data and integral types in one
> place unless you prefer to push this down to appropriate places where
> applicable, like add e.g. the basic type nodes and the "kind" node
> in gfc_init_types. Whatever is deemed to be more appropriate. WDYT?

[PATCH,FORTRAN 08/29] Add uop/name helpers

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Introduce a helper to construct a user operator from a name and the
reverse operation, i.e. a helper to construct a name from a user
operator.

gcc/fortran/ChangeLog:

2017-10-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (gfc_get_uop_from_name):
	(gfc_get_name_from_uop): Declare.
	* symbol.c (gfc_get_uop_from_name):
	(gfc_get_name_from_uop): Define.
	* module.c (load_omp_udrs): Use them.
---
 gcc/fortran/gfortran.h |  2 ++
 gcc/fortran/module.c   | 21 +++------------------
 gcc/fortran/symbol.c   | 21 +++++++++++++++++++++
 3 files changed, 26 insertions(+), 18 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ff42b39b453..6c32b8ac71f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3019,6 +3019,8 @@ void gfc_delete_symtree (gfc_symtree **, const char *);
 gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
 gfc_user_op *gfc_get_uop (const char *);
 gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
+const char *gfc_get_uop_from_name (const char*);
+const char *gfc_get_name_from_uop (const char*);
 void gfc_free_symbol (gfc_symbol *);
 void gfc_release_symbol (gfc_symbol *);
 gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8628f3aeda9..b3f68b8803f 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -4785,7 +4785,7 @@ load_omp_udrs (void)
   while (peek_atom () != ATOM_RPAREN)
     {
       const char *name = NULL, *newname;
-      char *altname;
+      const char *altname = NULL;
       gfc_typespec ts;
       gfc_symtree *st;
       gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
@@ -4812,15 +4812,8 @@ load_omp_udrs (void)
 	  else if (strcmp (p, ".neqv.") == 0)
 	    rop = OMP_REDUCTION_NEQV;
 	}
-      altname = NULL;
       if (rop == OMP_REDUCTION_USER && name[0] == '.')
-	{
-	  size_t len = strlen (name + 1);
-	  altname = XALLOCAVEC (char, len);
-	  gcc_assert (name[len] == '.');
-	  memcpy (altname, name + 1, len - 1);
-	  altname[len - 1] = '\0';
-	}
+	altname = gfc_get_name_from_uop (name);
       newname = name;
       if (rop == OMP_REDUCTION_USER)
 	newname = find_use_name (altname ? altname : name, !!altname);
@@ -4832,15 +4825,7 @@ load_omp_udrs (void)
 	  continue;
 	}
       if (altname && newname != altname)
-	{
-	  size_t len = strlen (newname);
-	  altname = XALLOCAVEC (char, len + 3);
-	  altname[0] = '.';
-	  memcpy (altname + 1, newname, len);
-	  altname[len + 1] = '.';
-	  altname[len + 2] = '\0';
-	  name = gfc_get_string ("%s", altname);
-	}
+	name = altname = gfc_get_uop_from_name (newname);
       st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
       gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
       if (udr)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0a4f7c1711b..a8f841185f1 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3026,6 +3026,27 @@ gfc_find_uop (const char *name, gfc_namespace *ns)
   return (st == NULL) ? NULL : st->n.uop;
 }
 
+/* Given a name return a string usable as user operator name.  */
+const char *
+gfc_get_uop_from_name (const char* name) {
+  gcc_assert (name[0] != '.');
+  return gfc_get_string (".%s.", name);
+}
+
+/* Given a user operator name return a string usable as name.  */
+const char *
+gfc_get_name_from_uop (const char* name) {
+  gcc_assert (name[0] == '.');
+  const size_t len = strlen (name) - 1;
+  gcc_assert (len > 1);
+  gcc_assert (name[len] == '.');
+  char *buffer = XNEWVEC (char, len);
+  memcpy (buffer, name + 1, len - 1);
+  buffer[len - 1] = '\0';
+  const char *ret = gfc_get_string ("%s", buffer);
+  XDELETEVEC (buffer);
+  return ret;
+}
 
 /* Update a symbol's common_block field, and take care of the associated
    memory management.  */
-- 
2.19.0.rc1

[PATCH,FORTRAN 07/29] Use stringpool for some gfc_code2string return values

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Use a stringpool-node for those gfc_code2string values that are used as
names.

gcc/fortran/ChangeLog:

2017-10-26  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* interface.c (gfc_match_generic_spec, gfc_check_dtio_interfaces,
	gfc_find_typebound_dtio_proc, gfc_find_specific_dtio_proc): Use
	stringpool node for those return values of gfc_code2string that
	are used as names.
---
 gcc/fortran/interface.c | 50 ++++++++++++++++-------------------------
 1 file changed, 19 insertions(+), 31 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 19a0eb28edd..8716813b7b2 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -182,12 +182,12 @@ gfc_match_generic_spec (interface_type *type,
       *op = dtio_op (name);
       if (*op == INTRINSIC_FORMATTED)
 	{
-	  name = gfc_code2string (dtio_procs, DTIO_RF);
+	  name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF));
 	  *type = INTERFACE_DTIO;
 	}
       if (*op == INTRINSIC_UNFORMATTED)
 	{
-	  name = gfc_code2string (dtio_procs, DTIO_RUF);
+	  name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF));
 	  *type = INTERFACE_DTIO;
 	}
       if (*op != INTRINSIC_NONE)
@@ -199,12 +199,12 @@ gfc_match_generic_spec (interface_type *type,
       *op = dtio_op (name);
       if (*op == INTRINSIC_FORMATTED)
 	{
-	  name = gfc_code2string (dtio_procs, DTIO_WF);
+	  name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF));
 	  *type = INTERFACE_DTIO;
 	}
       if (*op == INTRINSIC_UNFORMATTED)
 	{
-	  name = gfc_code2string (dtio_procs, DTIO_WUF);
+	  name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF));
 	  *type = INTERFACE_DTIO;
 	}
       if (*op != INTRINSIC_NONE)
@@ -4927,8 +4927,8 @@ gfc_check_dtio_interfaces (gfc_symbol *derived)
 		   || ((dtio_codes)code == DTIO_WF);
 
       tb_io_st = gfc_find_typebound_proc (derived, &t,
-					  gfc_code2string (dtio_procs, code),
-					  true, &derived->declared_at);
+	  gfc_get_string ("%s", gfc_code2string (dtio_procs, code)),
+	  true, &derived->declared_at);
       if (tb_io_st != NULL)
 	check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
     }
@@ -4940,7 +4940,7 @@ gfc_check_dtio_interfaces (gfc_symbol *derived)
 		   || ((dtio_codes)code == DTIO_WF);
 
       tb_io_st = gfc_find_symtree (derived->ns->sym_root,
-				   gfc_code2string (dtio_procs, code));
+	  gfc_get_string ("%s", gfc_code2string (dtio_procs, code)));
       if (tb_io_st != NULL)
 	check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
     }
@@ -4961,31 +4961,23 @@ gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
     {
       if (write == true)
         tb_io_st = gfc_find_typebound_proc (derived, &t,
-					    gfc_code2string (dtio_procs,
-							     DTIO_WF),
-					    true,
-					    &derived->declared_at);
+	    gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF)),
+	    true, &derived->declared_at);
       else
         tb_io_st = gfc_find_typebound_proc (derived, &t,
-					    gfc_code2string (dtio_procs,
-							     DTIO_RF),
-					    true,
-					    &derived->declared_at);
+	    gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF)),
+	    true, &derived->declared_at);
     }
   else
     {
       if (write == true)
         tb_io_st = gfc_find_typebound_proc (derived, &t,
-					    gfc_code2string (dtio_procs,
-							     DTIO_WUF),
-					    true,
-					    &derived->declared_at);
+	    gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF)),
+	    true, &derived->declared_at);
       else
         tb_io_st = gfc_find_typebound_proc (derived, &t,
-					    gfc_code2string (dtio_procs,
-							     DTIO_RUF),
-					    true,
-					    &derived->declared_at);
+	    gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF)),
+	    true, &derived->declared_at);
     }
   return tb_io_st;
 }
@@ -5041,23 +5033,19 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
 	{
 	  if (write == true)
 	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
-					 gfc_code2string (dtio_procs,
-							  DTIO_WF));
+		gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF)));
 	  else
 	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
-					 gfc_code2string (dtio_procs,
-							  DTIO_RF));
+		gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF)));
 	}
       else
 	{
 	  if (write == true)
 	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
-					 gfc_code2string (dtio_procs,
-							  DTIO_WUF));
+		gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF)));
 	  else
 	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
-					 gfc_code2string (dtio_procs,
-							  DTIO_RUF));
+		gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF)));
 	}
 
       if (tb_io_st != NULL
-- 
2.19.0.rc1

[PATCH,FORTRAN 03/29] Use stringpool for gfc_get_name

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Occurrences of name2 in this patch will be fixed later in this series.

gcc/fortran/ChangeLog:

2017-10-23  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.h (gfc_match_name): Pass argument by reference. Adjust
	all callers.
	(match_common_name): Likewise.
	* match.c (gfc_match_name): Set result to IDENTIFIER_POINTER of
	stringpool node.
	(gfc_match_member_sep, gfc_match_sym_tree, gfc_match,
	gfc_match_else, gfc_match_elseif, match_common_name,
	gfc_match_common, gfc_match_ptr_fcn_assign, match_case_eos,
	gfc_match_elsewhere): Adjust.
	* decl.c (variable_decl): Set name via gfc_get_string() and
	adjust calls to gfc_match_name.
	(match_data_constant, check_function_name, get_bind_c_idents,
	gfc_match_formal_arglist, match_result, match_procedure_interface,
	match_ppc_decl, match_procedure_in_interface, gfc_match_entry,
	gfc_match_end, attr_decl1, gfc_match_modproc, gfc_match_type,
	enumerator_decl, match_procedure_in_type, gfc_match_generic,
	gfc_match_final_decl, gfc_match_gcc_attributes): Adjust.
	* interface.c (gfc_match_generic_spec): Adjust.
	* io.c (match_io): Adjust.
	* module.c (gfc_match_use): Adjust.
	* openmp.c (gfc_match_omp_clauses, gfc_match_oacc_routine): Adjust.
	* primary.c (match_kind_param, match_sym_complex_part,
	match_actual_arg, match_keyword_arg, gfc_match_varspec,
	gfc_match_rvalue): Adjust.
---
 gcc/fortran/decl.c      | 95 +++++++++++++++++++++--------------------
 gcc/fortran/interface.c |  5 ++-
 gcc/fortran/io.c        |  6 +--
 gcc/fortran/match.c     | 56 +++++++++++++-----------
 gcc/fortran/match.h     |  4 +-
 gcc/fortran/module.c    |  5 ++-
 gcc/fortran/openmp.c    | 25 +++++------
 gcc/fortran/primary.c   | 31 +++++++-------
 8 files changed, 116 insertions(+), 111 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 03298833c98..f0ff5138ca1 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -352,7 +352,7 @@ syntax:
 static match
 match_data_constant (gfc_expr **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym, *dt_sym = NULL;
   gfc_expr *expr;
   match m;
@@ -404,7 +404,7 @@ match_data_constant (gfc_expr **result)
 
   gfc_current_locus = old_loc;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -2261,7 +2261,7 @@ match_pointer_init (gfc_expr **init, int procptr)
 
 
 static bool
-check_function_name (char *name)
+check_function_name (const char *name)
 {
   /* In functions that have a RESULT variable defined, the function name always
      refers to function calls.  Therefore, the name is not allowed to appear in
@@ -2294,7 +2294,7 @@ check_function_name (char *name)
 static match
 variable_decl (int elem)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   static unsigned int fill_id = 0;
   gfc_expr *initializer, *char_len;
   gfc_array_spec *as;
@@ -2326,7 +2326,7 @@ variable_decl (int elem)
 
   if (m != MATCH_YES)
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m != MATCH_YES)
 	goto cleanup;
     }
@@ -2351,7 +2351,7 @@ variable_decl (int elem)
 	}
 
       /* %FILL components are given invalid fortran names.  */
-      snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
+      name = gfc_get_string ("%%FILL%u", fill_id++);
       m = MATCH_YES;
     }
 
@@ -2584,13 +2584,13 @@ variable_decl (int elem)
   if (gfc_current_state () == COMP_FUNCTION
       && strcmp ("ppr@", gfc_current_block ()->name) == 0
       && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
-    strcpy (name, "ppr@");
+    name = gfc_get_string ("%s", "ppr@");
 
   if (gfc_current_state () == COMP_FUNCTION
       && strcmp (name, gfc_current_block ()->name) == 0
       && gfc_current_block ()->result
       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
-    strcpy (name, "ppr@");
+    name = gfc_get_string ("%s", "ppr@");
 
   /* OK, we've successfully matched the declaration.  Now put the
      symbol in the current namespace, because it might be used in the
@@ -5694,13 +5694,13 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
 bool
 get_bind_c_idents (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   int num_idents = 0;
   gfc_symbol *tmp_sym = NULL;
   match found_id;
   gfc_common_head *com_block = NULL;
 
-  if (gfc_match_name (name) == MATCH_YES)
+  if (gfc_match_name (&name) == MATCH_YES)
     {
       found_id = MATCH_YES;
       gfc_get_ha_symbol (name, &tmp_sym);
@@ -5745,7 +5745,7 @@ get_bind_c_idents (void)
 	    found_id = MATCH_NO;
 	  else if (gfc_match_char (',') != MATCH_YES)
 	    found_id = MATCH_NO;
-	  else if (gfc_match_name (name) == MATCH_YES)
+	  else if (gfc_match_name (&name) == MATCH_YES)
 	    {
 	      found_id = MATCH_YES;
 	      gfc_get_ha_symbol (name, &tmp_sym);
@@ -6126,7 +6126,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
 			  int null_flag, bool typeparam)
 {
   gfc_formal_arglist *head, *tail, *p, *q;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   gfc_formal_arglist *formal = NULL;
@@ -6173,7 +6173,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
 	}
       else
 	{
-	  m = gfc_match_name (name);
+	  m = gfc_match_name (&name);
 	  if (m != MATCH_YES)
 	    {
 	      if(typeparam)
@@ -6317,14 +6317,14 @@ cleanup:
 static match
 match_result (gfc_symbol *function, gfc_symbol **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *r;
   match m;
 
   if (gfc_match (" result (") != MATCH_YES)
     return MATCH_NO;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -6515,7 +6515,7 @@ match_procedure_interface (gfc_symbol **proc_if)
   gfc_symtree *st;
   locus old_loc, entry_loc;
   gfc_namespace *old_ns = gfc_current_ns;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
 
   old_loc = entry_loc = gfc_current_locus;
   gfc_clear_ts (&current_ts);
@@ -6538,7 +6538,7 @@ match_procedure_interface (gfc_symbol **proc_if)
 
   /* Procedure interface is itself a procedure.  */
   gfc_current_locus = old_loc;
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
 
   /* First look to see if it is already accessible in the current
      namespace because it is use associated or contained.  */
@@ -6737,7 +6737,7 @@ match_ppc_decl (void)
   gfc_component *c;
   gfc_expr *initializer = NULL;
   gfc_typebound_proc* tb;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
 
   /* Parse interface (with brackets).  */
   m = match_procedure_interface (&proc_if);
@@ -6778,7 +6778,7 @@ match_ppc_decl (void)
   ts = current_ts;
   for(num=1;;num++)
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	goto syntax;
       else if (m == MATCH_ERROR)
@@ -6855,7 +6855,7 @@ match_procedure_in_interface (void)
 {
   match m;
   gfc_symbol *sym;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   locus old_locus;
 
   if (current_interface.type == INTERFACE_NAMELESS
@@ -6879,7 +6879,7 @@ match_procedure_in_interface (void)
 
   for(;;)
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	goto syntax;
       else if (m == MATCH_ERROR)
@@ -7180,7 +7180,7 @@ gfc_match_entry (void)
   gfc_symbol *proc;
   gfc_symbol *result;
   gfc_symbol *entry;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_compile_state state;
   match m;
   gfc_entry_list *el;
@@ -7189,7 +7189,7 @@ gfc_match_entry (void)
   char peek_char;
   match is_bind_c;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -7787,7 +7787,7 @@ set_enum_kind(void)
 match
 gfc_match_end (gfc_statement *st)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_compile_state state;
   locus old_loc;
   const char *block_name;
@@ -8031,7 +8031,7 @@ gfc_match_end (gfc_statement *st)
      end-name.  */
   m = gfc_match_space ();
   if (m == MATCH_YES)
-    m = gfc_match_name (name);
+    m = gfc_match_name (&name);
 
   if (m == MATCH_NO)
     gfc_error ("Expected terminating name at %C");
@@ -8113,7 +8113,7 @@ cleanup:
 static match
 attr_decl1 (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_array_spec *as;
 
   /* Workaround -Wmaybe-uninitialized false positive during
@@ -8124,7 +8124,7 @@ attr_decl1 (void)
 
   as = NULL;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     goto cleanup;
 
@@ -9384,7 +9384,7 @@ cleanup:
 match
 gfc_match_modproc (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   locus old_locus;
@@ -9433,7 +9433,7 @@ gfc_match_modproc (void)
       bool last = false;
       old_locus = gfc_current_locus;
 
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	goto syntax;
       if (m != MATCH_YES)
@@ -9818,7 +9818,7 @@ gfc_match_structure_decl (void)
 match
 gfc_match_type (gfc_statement *st)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   match m;
   locus old_loc;
 
@@ -9844,7 +9844,7 @@ gfc_match_type (gfc_statement *st)
 
   /* By now "TYPE" has already been matched. If we do not see a name, this may
    * be something like "TYPE *" or "TYPE <fmt>".  */
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     {
       /* Let print match if it can, otherwise throw an error from
@@ -10236,7 +10236,7 @@ enum_initializer (gfc_expr *last_initializer, locus where)
 static match
 enumerator_decl (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_expr *initializer;
   gfc_array_spec *as = NULL;
   gfc_symbol *sym;
@@ -10251,7 +10251,7 @@ enumerator_decl (void)
   /* When we get here, we've just matched a list of attributes and
      maybe a type and a double colon.  The next thing we expect to see
      is the name of the symbol.  */
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     goto cleanup;
 
@@ -10591,9 +10591,9 @@ error:
 static match
 match_procedure_in_type (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
-  char target_buf[GFC_MAX_SYMBOL_LEN + 1];
-  char* target = NULL, *ifc = NULL;
+  const char *name = NULL;
+  const char *target_buf = NULL;
+  const char *target = NULL, *ifc = NULL;
   gfc_typebound_proc tb;
   bool seen_colons;
   bool seen_attrs;
@@ -10611,7 +10611,7 @@ match_procedure_in_type (void)
   /* Try to match PROCEDURE(interface).  */
   if (gfc_match (" (") == MATCH_YES)
     {
-      m = gfc_match_name (target_buf);
+      m = gfc_match_name (&target_buf);
       if (m == MATCH_ERROR)
 	return m;
       if (m != MATCH_YES)
@@ -10665,7 +10665,7 @@ match_procedure_in_type (void)
   /* Match the binding names.  */
   for(num=1;;num++)
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_ERROR)
 	return m;
       if (m == MATCH_NO)
@@ -10697,7 +10697,7 @@ match_procedure_in_type (void)
 	      return MATCH_ERROR;
 	    }
 
-	  m = gfc_match_name (target_buf);
+	  m = gfc_match_name (&target_buf);
 	  if (m == MATCH_ERROR)
 	    return m;
 	  if (m == MATCH_NO)
@@ -10931,8 +10931,9 @@ gfc_match_generic (void)
     {
       gfc_symtree* target_st;
       gfc_tbp_generic* target;
+      const char *name2 = NULL;
 
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name2);
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_NO)
@@ -10941,14 +10942,14 @@ gfc_match_generic (void)
 	  goto error;
 	}
 
-      target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
+      target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name2);
 
       /* See if this is a duplicate specification.  */
       for (target = tb->u.generic; target; target = target->next)
 	if (target_st == target->specific_st)
 	  {
 	    gfc_error ("%qs already defined as specific binding for the"
-		       " generic %qs at %C", name, bind_name);
+		       " generic %qs at %C", name2, bind_name);
 	    goto error;
 	  }
 
@@ -10981,7 +10982,7 @@ error:
 match
 gfc_match_final_decl (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol* sym;
   match m;
   gfc_namespace* module_ns;
@@ -11037,7 +11038,7 @@ gfc_match_final_decl (void)
 	  return MATCH_ERROR;
 	}
 
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	{
 	  gfc_error ("Expected module procedure name at %C");
@@ -11120,7 +11121,7 @@ match
 gfc_match_gcc_attributes (void)
 {
   symbol_attribute attr;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   unsigned id;
   gfc_symbol *sym;
   match m;
@@ -11130,7 +11131,7 @@ gfc_match_gcc_attributes (void)
     {
       char ch;
 
-      if (gfc_match_name (name) != MATCH_YES)
+      if (gfc_match_name (&name) != MATCH_YES)
 	return MATCH_ERROR;
 
       for (id = 0; id < EXT_ATTR_LAST; id++)
@@ -11166,7 +11167,7 @@ gfc_match_gcc_attributes (void)
 
   for(;;)
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m != MATCH_YES)
 	return m;
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 14137cebd6c..de58eed23f0 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -140,6 +140,7 @@ gfc_match_generic_spec (interface_type *type,
 			gfc_intrinsic_op *op)
 {
   char buffer[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name2 = NULL;
   match m;
   gfc_intrinsic_op i;
 
@@ -212,9 +213,9 @@ gfc_match_generic_spec (interface_type *type,
 	return MATCH_YES;
     }
 
-  if (gfc_match_name (buffer) == MATCH_YES)
+  if (gfc_match_name (&name2) == MATCH_YES)
     {
-      strcpy (name, buffer);
+      strcpy (name, name2);
       *type = INTERFACE_GENERIC;
       return MATCH_YES;
     }
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 0aa31bb6a4f..1d07076c377 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -4071,7 +4071,7 @@ if (condition) \
 static match
 match_io (io_kind k)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_code *io_code;
   gfc_symbol *sym;
   int comma_flag;
@@ -4093,7 +4093,7 @@ match_io (io_kind k)
 	{
 	  /* Treat the non-standard case of PRINT namelist.  */
 	  if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
-	      && gfc_match_name (name) == MATCH_YES)
+	      && gfc_match_name (&name) == MATCH_YES)
 	    {
 	      gfc_find_symbol (name, NULL, 1, &sym);
 	      if (sym && sym->attr.flavor == FL_NAMELIST)
@@ -4219,7 +4219,7 @@ match_io (io_kind k)
 
   where = gfc_current_locus;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m == MATCH_YES)
     {
       gfc_find_symbol (name, NULL, 1, &sym);
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 85247dd8334..f3ad91a07c0 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -25,6 +25,8 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "match.h"
 #include "parse.h"
+#include "stringpool.h"
+#include "tree.h"
 
 int gfc_matching_ptr_assignment = 0;
 int gfc_matching_procptr_assignment = 0;
@@ -150,7 +152,7 @@ gfc_op2string (gfc_intrinsic_op op)
 match
 gfc_match_member_sep(gfc_symbol *sym)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   locus dot_loc, start_loc;
   gfc_intrinsic_op iop;
   match m;
@@ -176,7 +178,6 @@ gfc_match_member_sep(gfc_symbol *sym)
     tsym = sym->ts.u.derived;
 
   iop = INTRINSIC_NONE;
-  name[0] = '\0';
   m = MATCH_NO;
 
   /* If we have to reject come back here later.  */
@@ -190,7 +191,7 @@ gfc_match_member_sep(gfc_symbol *sym)
   dot_loc = gfc_current_locus;
 
   /* Try to match a symbol name following the dot.  */
-  if (gfc_match_name (name) != MATCH_YES)
+  if (gfc_match_name (&name) != MATCH_YES)
     {
       gfc_error ("Expected structure component or operator name "
                  "after '.' at %C");
@@ -634,17 +635,18 @@ gfc_match_label (void)
 }
 
 
-/* See if the current input looks like a name of some sort.  Modifies
-   the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
+/* See if the current input looks like a name of some sort.
+   Upon success RESULT is set to the matched name and MATCH_YES is returned.
    Note that options.c restricts max_identifier_length to not more
    than GFC_MAX_SYMBOL_LEN.  */
 
 match
-gfc_match_name (char *buffer)
+gfc_match_name (const char **result)
 {
   locus old_loc;
   int i;
   char c;
+  char buffer[GFC_MAX_SYMBOL_LEN + 1];
 
   old_loc = gfc_current_locus;
   gfc_gobble_whitespace ();
@@ -685,7 +687,7 @@ gfc_match_name (char *buffer)
       return MATCH_ERROR;
     }
 
-  buffer[i] = '\0';
+  *result = IDENTIFIER_POINTER (get_identifier_with_length (buffer, i));
   gfc_current_locus = old_loc;
 
   return MATCH_YES;
@@ -698,10 +700,10 @@ gfc_match_name (char *buffer)
 match
 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
 {
-  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+  const char *buffer = NULL;
   match m;
 
-  m = gfc_match_name (buffer);
+  m = gfc_match_name (&buffer);
   if (m != MATCH_YES)
     return m;
 
@@ -1123,6 +1125,7 @@ gfc_match (const char *target, ...)
   locus old_loc;
   va_list argp;
   char c, *np;
+  const char *name2_hack = NULL;
   match m, n;
   void **vp;
   const char *p;
@@ -1186,12 +1189,13 @@ loop:
 
 	case 'n':
 	  np = va_arg (argp, char *);
-	  n = gfc_match_name (np);
+	  n = gfc_match_name (&name2_hack);
 	  if (n != MATCH_YES)
 	    {
 	      m = n;
 	      goto not_yes;
 	    }
+	  strcpy (np, name2_hack);
 
 	  matches++;
 	  goto loop;
@@ -1694,12 +1698,12 @@ got_match:
 match
 gfc_match_else (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
 
   if (gfc_match_eos () == MATCH_YES)
     return MATCH_YES;
 
-  if (gfc_match_name (name) != MATCH_YES
+  if (gfc_match_name (&name) != MATCH_YES
       || gfc_current_block () == NULL
       || gfc_match_eos () != MATCH_YES)
     {
@@ -1723,7 +1727,7 @@ gfc_match_else (void)
 match
 gfc_match_elseif (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_expr *expr;
   match m;
 
@@ -1734,7 +1738,7 @@ gfc_match_elseif (void)
   if (gfc_match_eos () == MATCH_YES)
     goto done;
 
-  if (gfc_match_name (name) != MATCH_YES
+  if (gfc_match_name (&name) != MATCH_YES
       || gfc_current_block () == NULL
       || gfc_match_eos () != MATCH_YES)
     {
@@ -5029,23 +5033,23 @@ gfc_get_common (const char *name, int from_module)
 
 /* Match a common block name.  */
 
-match match_common_name (char *name)
+match match_common_name (const char *&name)
 {
   match m;
 
   if (gfc_match_char ('/') == MATCH_NO)
     {
-      name[0] = '\0';
+      name = NULL;
       return MATCH_YES;
     }
 
   if (gfc_match_char ('/') == MATCH_YES)
     {
-      name[0] = '\0';
+      name = NULL;
       return MATCH_YES;
     }
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
 
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
@@ -5063,7 +5067,7 @@ match
 gfc_match_common (void)
 {
   gfc_symbol *sym, **head, *tail, *other;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_common_head *t;
   gfc_array_spec *as;
   gfc_equiv *e1, *e2;
@@ -5077,7 +5081,7 @@ gfc_match_common (void)
       if (m == MATCH_ERROR)
 	goto cleanup;
 
-      if (name[0] == '\0')
+      if (name == NULL)
 	{
 	  t = &gfc_current_ns->blank_common;
 	  if (t->head == NULL)
@@ -5736,10 +5740,10 @@ gfc_match_ptr_fcn_assign (void)
   gfc_symbol *sym;
   gfc_expr *expr;
   match m;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
 
   old_loc = gfc_current_locus;
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -5888,7 +5892,7 @@ cleanup:
 static match
 match_case_eos (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   match m;
 
   if (gfc_match_eos () == MATCH_YES)
@@ -5901,7 +5905,7 @@ match_case_eos (void)
 
   gfc_gobble_whitespace ();
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -6589,7 +6593,7 @@ gfc_match_where (gfc_statement *st)
 match
 gfc_match_elsewhere (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_expr *expr;
   match m;
 
@@ -6622,7 +6626,7 @@ gfc_match_elsewhere (void)
 	  goto cleanup;
 	}
       /* Better be a name at this point.  */
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	goto syntax;
       if (m == MATCH_ERROR)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index b3ced3f8454..62554d9667e 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -50,7 +50,7 @@ match gfc_match_st_label (gfc_st_label **);
 match gfc_match_label (void);
 match gfc_match_small_int (int *);
 match gfc_match_small_int_expr (int *, gfc_expr **);
-match gfc_match_name (char *);
+match gfc_match_name (const char **);
 match gfc_match_name_C (const char **buffer);
 match gfc_match_symbol (gfc_symbol **, int);
 match gfc_match_sym_tree (gfc_symtree **, int);
@@ -107,7 +107,7 @@ match gfc_match_call (void);
  
    TODO: should probably rename this now that it'll be globally seen to
    gfc_match_common_name.  */
-match match_common_name (char *name);
+match match_common_name (const char *&name);
 
 match gfc_match_common (void);
 match gfc_match_block_data (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 993ea9f16b9..f31677b3b5e 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -520,6 +520,7 @@ match
 gfc_match_use (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name2 = NULL;
   gfc_use_rename *tail = NULL, *new_use;
   interface_type type, type2;
   gfc_intrinsic_op op;
@@ -583,14 +584,14 @@ gfc_match_use (void)
 
   use_list->where = gfc_current_locus;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name2);
   if (m != MATCH_YES)
     {
       free (use_list);
       return m;
     }
 
-  use_list->module_name = gfc_get_string ("%s", name);
+  use_list->module_name = name2;
 
   if (gfc_match_eos () == MATCH_YES)
     goto done;
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index a852fc490db..10a5df92e61 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1580,8 +1580,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      && gfc_match ("reduction ( ") == MATCH_YES)
 	    {
 	      gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
-	      char buffer[GFC_MAX_SYMBOL_LEN + 3];
-	      const char *op = NULL;
+	      const char *buffer = NULL;
 	      if (gfc_match_char ('+') == MATCH_YES)
 		rop = OMP_REDUCTION_PLUS;
 	      else if (gfc_match_char ('*') == MATCH_YES)
@@ -1597,11 +1596,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      else if (gfc_match (".neqv.") == MATCH_YES)
 		rop = OMP_REDUCTION_NEQV;
 	      if (rop != OMP_REDUCTION_NONE)
-		op = gfc_get_string ("operator %s",
+		buffer = gfc_get_string ("operator %s",
 			  gfc_op2string ((gfc_intrinsic_op) rop));
-	      else if (gfc_match_defined_op_name (op, 1, 1) == MATCH_YES)
+	      else if (gfc_match_defined_op_name (buffer, 1, 1) == MATCH_YES)
 		;
-	      else if (gfc_match_name (buffer) == MATCH_YES)
+	      else if (gfc_match_name (&buffer) == MATCH_YES)
 		{
 		  gfc_symbol *sym;
 		  const char *n = buffer;
@@ -1657,11 +1656,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		    rop = OMP_REDUCTION_NONE;
 		}
 	      else
-		buffer[0] = '\0';
+		buffer = NULL;
 	      gfc_omp_udr *udr;
-	      if (op != NULL)
-		udr = gfc_find_omp_udr (gfc_current_ns, op, NULL);
-	      else if (buffer[0])
+	      if (buffer != NULL)
 		udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
 	      else
 		udr = NULL;
@@ -1680,7 +1677,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		      n = *head;
 		      *head = NULL;
 		      gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
-				     "at %L", op ? op : buffer, &old_loc);
+				     "at %L", buffer, &old_loc);
 		      gfc_free_omp_namelist (n);
 		    }
 		  else
@@ -2290,13 +2287,13 @@ gfc_match_oacc_routine (void)
 
   if (m == MATCH_YES)
     {
-      char buffer[GFC_MAX_SYMBOL_LEN + 1];
+      const char *name = NULL;
       gfc_symtree *st;
 
-      m = gfc_match_name (buffer);
+      m = gfc_match_name (&name);
       if (m == MATCH_YES)
 	{
-	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, name);
 	  if (st)
 	    {
 	      sym = st->n.sym;
@@ -2313,7 +2310,7 @@ gfc_match_oacc_routine (void)
 	    {
 	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
 			 "invalid function name %s",
-			 (sym) ? sym->name : buffer);
+			 (sym) ? sym->name : name);
 	      gfc_current_locus = old_loc;
 	      return MATCH_ERROR;
 	    }
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 094f2101bbc..b30938ef61c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -39,7 +39,7 @@ int matching_actual_arglist = 0;
 static match
 match_kind_param (int *kind, int *is_iso_c)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
 
@@ -49,7 +49,7 @@ match_kind_param (int *kind, int *is_iso_c)
   if (m != MATCH_NO)
     return m;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -1234,12 +1234,12 @@ match_logical_constant (gfc_expr **result)
 static match
 match_sym_complex_part (gfc_expr **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   gfc_expr *e;
   match m;
 
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     return m;
 
@@ -1525,7 +1525,7 @@ gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
 static match
 match_actual_arg (gfc_expr **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symtree *symtree;
   locus where, w;
   gfc_expr *e;
@@ -1534,7 +1534,7 @@ match_actual_arg (gfc_expr **result)
   gfc_gobble_whitespace ();
   where = gfc_current_locus;
 
-  switch (gfc_match_name (name))
+  switch (gfc_match_name (&name))
     {
     case MATCH_ERROR:
       return MATCH_ERROR;
@@ -1629,13 +1629,13 @@ match_actual_arg (gfc_expr **result)
 static match
 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_actual_arglist *a;
   locus name_locus;
   match m;
 
   name_locus = gfc_current_locus;
-  m = gfc_match_name (name);
+  m = gfc_match_name (&name);
 
   if (m != MATCH_YES)
     goto cleanup;
@@ -1667,7 +1667,7 @@ match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pd
 
   /* Make sure this name has not appeared yet.  */
 add_name:
-  if (name[0] != '\0')
+  if (name != NULL)
     {
       for (a = base; a; a = a->next)
 	if (a->name != NULL && strcmp (a->name, name) == 0)
@@ -1678,7 +1678,7 @@ add_name:
 	  }
     }
 
-  actual->name = gfc_get_string ("%s", name);
+  actual->name = name;
   return MATCH_YES;
 
 cleanup:
@@ -1948,7 +1948,7 @@ match
 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 		   bool ppc_arg)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_ref *substring, *tail, *tmp;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
@@ -2136,7 +2136,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       bool t;
       gfc_symtree *tbp;
 
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m == MATCH_NO)
 	gfc_error ("Expected structure component name at %C");
       if (m != MATCH_YES)
@@ -3144,7 +3144,8 @@ match
 gfc_match_rvalue (gfc_expr **result)
 {
   gfc_actual_arglist *actual_arglist;
-  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
+  char argname[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_state_data *st;
   gfc_symbol *sym;
   gfc_symtree *symtree;
@@ -3161,12 +3162,12 @@ gfc_match_rvalue (gfc_expr **result)
     {
       if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
         return MATCH_ERROR;
-      strncpy (name, "loc", 4);
+      name = gfc_get_string ("%s", "loc");
     }
 
   else
     {
-      m = gfc_match_name (name);
+      m = gfc_match_name (&name);
       if (m != MATCH_YES)
         return m;
     }
-- 
2.19.0.rc1

[PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Bernhard Reutner-Fischer]

Hi,

The fortran frontend still uses stack-based handling of (symbol) names
with fixed-sized buffers. Furthermore these buffers often are too small
when dealing with F2003 identifiers which can be up to, including 63
bytes long.

Other frontends use the stringpool since many years.
This janitorial series is a first step towards using the stringpool in
the frontend.
Consequently this allows us to use pointer-comparison to see if two
given "names" are identical instead of doing lots and lots of string
comparisons.


Part 1 switches most of the fortran FE. An eventual part 2 would
continue to switch the few remaining stack-based identifier
manipulations to use the stringpool. My initial plan was to also see if
switching gfc_symtree from treap to a hash_map would bring us any
measurable benefit, but that, too, is left for an eventual part 2.

Bootstrapped and regtested on x86_64-foo-linux.

I'd appreciate if someone could double check for regressions on other
setups. Git branch:
https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool

Ok for trunk?

Bernhard Reutner-Fischer (29):
  gdbinit: break on gfc_internal_error
  Use stringpool for gfc_match_defined_op_name()
  Use stringpool for gfc_get_name
  Use stringpool for gfc_match_generic_spec
  Use stringpool for gfc_match("%n")
  Use stringpool for association_list
  Use stringpool for some gfc_code2string return values
  Add uop/name helpers
  Use stringpool for modules
  Do not copy name for check_function_name
  Do pointer comparison instead of strcmp
  Use stringpool for remaining names
  Use stringpool for intrinsics and common
  Fix write_omp_udr for user-operator REDUCTIONs
  Use stringpool for iso_c_binding module names
  Do pointer comparison in iso_c_binding_module
  Use stringpool for iso_fortran_env
  Use stringpool for charkind
  Use stringpool and unified uppercase handling for types
  Use stringpool in class et al
  Use stringpool for module tbp
  Use stringpool in class and procedure-pointer result
  Use stringpool for module binding_label
  Use stringpool for intrinsic functions
  Use stringpool on loading module symbols
  Use stringpool for mangled common names
  Use stringpool for OMP clause reduction code
  Free type-bound procedure structs
  PR87103: Remove max symbol length check from gfc_new_symbol

 gcc/fortran/check.c           |   2 +-
 gcc/fortran/class.c           |  96 +++++------
 gcc/fortran/decl.c            | 265 ++++++++++++++---------------
 gcc/fortran/expr.c            |   4 +-
 gcc/fortran/frontend-passes.c |  16 +-
 gcc/fortran/gfortran.h        |  18 +-
 gcc/fortran/interface.c       | 109 ++++++------
 gcc/fortran/intrinsic.c       |  11 +-
 gcc/fortran/io.c              |  10 +-
 gcc/fortran/iresolve.c        |  35 ++--
 gcc/fortran/match.c           | 143 ++++++++--------
 gcc/fortran/match.h           |   9 +-
 gcc/fortran/matchexp.c        |  22 ++-
 gcc/fortran/misc.c            |   2 +-
 gcc/fortran/module.c          | 311 ++++++++++++++--------------------
 gcc/fortran/openmp.c          | 120 +++++++------
 gcc/fortran/parse.c           |  23 ++-
 gcc/fortran/primary.c         |  58 ++++---
 gcc/fortran/resolve.c         |  81 +++++----
 gcc/fortran/symbol.c          |  58 ++++---
 gcc/fortran/trans-array.c     |   4 +-
 gcc/fortran/trans-common.c    |  10 +-
 gcc/fortran/trans-decl.c      |  38 ++---
 gcc/fortran/trans-expr.c      |  11 +-
 gcc/fortran/trans-openmp.c    |   1 +
 gcc/fortran/trans-types.c     |  20 +--
 gcc/fortran/trans.c           |   6 +-
 gcc/gdbinit.in                |   1 +
 28 files changed, 719 insertions(+), 765 deletions(-)

-- 
2.19.0.rc1

[PATCH,FORTRAN 02/29] Use stringpool for gfc_match_defined_op_name()

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

The openmp part will be cleaned up later in this series.

gcc/fortran/ChangeLog:

2017-10-22  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.h (gfc_match_defined_op_name): Adjust prototype and add
	a parameter USER_OPERATOR.
	* matchexp.c (gfc_match_defined_op_name): Use gfc_get_string and
	return a user operator if USER_OPERATOR is true.
	(match_defined_operator): Update calls to gfc_match_defined_op_name.
	* interface.c (gfc_match_generic_spec): Likewise.
	* openmp.c (gfc_match_omp_clauses): Likewise. Use gfc_get_string
	where appropriate.
	(gfc_match_omp_declare_reduction): Likewise.
---
 gcc/fortran/interface.c |  5 +++--
 gcc/fortran/match.h     |  2 +-
 gcc/fortran/matchexp.c  | 18 ++++++++++++------
 gcc/fortran/openmp.c    | 31 +++++++++++++++++--------------
 4 files changed, 33 insertions(+), 23 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f85c76bad0f..14137cebd6c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -160,7 +160,8 @@ gfc_match_generic_spec (interface_type *type,
   *op = INTRINSIC_NONE;
   if (gfc_match (" operator ( ") == MATCH_YES)
     {
-      m = gfc_match_defined_op_name (buffer, 1);
+      const char *oper = NULL;
+      m = gfc_match_defined_op_name (oper, 1, 0);
       if (m == MATCH_NO)
 	goto syntax;
       if (m != MATCH_YES)
@@ -172,7 +173,7 @@ gfc_match_generic_spec (interface_type *type,
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
-      strcpy (name, buffer);
+      strcpy (name, oper);
       *type = INTERFACE_USER_OP;
       return MATCH_YES;
     }
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 418542bd5a6..b3ced3f8454 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -315,7 +315,7 @@ match gfc_match_write (void);
 match gfc_match_print (void);
 
 /* matchexp.c.  */
-match gfc_match_defined_op_name (char *, int);
+match gfc_match_defined_op_name (const char *&, int, bool);
 match gfc_match_expr (gfc_expr **);
 
 /* module.c.  */
diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c
index fb81e10a6c2..bb01af9f636 100644
--- a/gcc/fortran/matchexp.c
+++ b/gcc/fortran/matchexp.c
@@ -30,10 +30,14 @@ static const char expression_syntax[] = N_("Syntax error in expression at %C");
 
 /* Match a user-defined operator name.  This is a normal name with a
    few restrictions.  The error_flag controls whether an error is
-   raised if 'true' or 'false' are used or not.  */
+   raised if 'true' or 'false' are used or not.
+   If USER_OPERATOR is true, a user operator is returned in RESULT
+   upon success.
+ */
 
 match
-gfc_match_defined_op_name (char *result, int error_flag)
+gfc_match_defined_op_name (const char *&result, int error_flag,
+    bool user_operator)
 {
   static const char * const badops[] = {
     "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
@@ -72,8 +76,10 @@ gfc_match_defined_op_name (char *result, int error_flag)
 	gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]);
 	return MATCH_ERROR;
       }
-
-  strcpy (result, name);
+  if (user_operator)
+    result = gfc_get_string (".%s.", name);
+  else
+    result = gfc_get_string ("%s", name);
   return MATCH_YES;
 
 error:
@@ -91,10 +97,10 @@ error:
 static match
 match_defined_operator (gfc_user_op **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   match m;
 
-  m = gfc_match_defined_op_name (name, 0);
+  m = gfc_match_defined_op_name (name, 0, 0);
   if (m != MATCH_YES)
     return m;
 
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 94a7f7eaa50..a852fc490db 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1581,6 +1581,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	    {
 	      gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
 	      char buffer[GFC_MAX_SYMBOL_LEN + 3];
+	      const char *op = NULL;
 	      if (gfc_match_char ('+') == MATCH_YES)
 		rop = OMP_REDUCTION_PLUS;
 	      else if (gfc_match_char ('*') == MATCH_YES)
@@ -1596,13 +1597,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      else if (gfc_match (".neqv.") == MATCH_YES)
 		rop = OMP_REDUCTION_NEQV;
 	      if (rop != OMP_REDUCTION_NONE)
-		snprintf (buffer, sizeof buffer, "operator %s",
+		op = gfc_get_string ("operator %s",
 			  gfc_op2string ((gfc_intrinsic_op) rop));
-	      else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
-		{
-		  buffer[0] = '.';
-		  strcat (buffer, ".");
-		}
+	      else if (gfc_match_defined_op_name (op, 1, 1) == MATCH_YES)
+		;
 	      else if (gfc_match_name (buffer) == MATCH_YES)
 		{
 		  gfc_symbol *sym;
@@ -1660,9 +1658,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		}
 	      else
 		buffer[0] = '\0';
-	      gfc_omp_udr *udr
-		= (buffer[0]
-		   ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
+	      gfc_omp_udr *udr;
+	      if (op != NULL)
+		udr = gfc_find_omp_udr (gfc_current_ns, op, NULL);
+	      else if (buffer[0])
+		udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
+	      else
+		udr = NULL;
 	      gfc_omp_namelist **head = NULL;
 	      if (rop == OMP_REDUCTION_NONE && udr)
 		rop = OMP_REDUCTION_USER;
@@ -1678,7 +1680,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		      n = *head;
 		      *head = NULL;
 		      gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
-				     "at %L", buffer, &old_loc);
+				     "at %L", op ? op : buffer, &old_loc);
 		      gfc_free_omp_namelist (n);
 		    }
 		  else
@@ -2801,6 +2803,7 @@ gfc_match_omp_declare_reduction (void)
   match m;
   gfc_intrinsic_op op;
   char name[GFC_MAX_SYMBOL_LEN + 3];
+  const char *oper = NULL;
   auto_vec<gfc_typespec, 5> tss;
   gfc_typespec ts;
   unsigned int i;
@@ -2818,20 +2821,20 @@ gfc_match_omp_declare_reduction (void)
     return MATCH_ERROR;
   if (m == MATCH_YES)
     {
-      snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
+      oper = gfc_get_string ("operator %s", gfc_op2string (op));
+      strcpy (name, oper);
       rop = (gfc_omp_reduction_op) op;
     }
   else
     {
-      m = gfc_match_defined_op_name (name + 1, 1);
+      m = gfc_match_defined_op_name (oper, 1, 1);
       if (m == MATCH_ERROR)
 	return MATCH_ERROR;
       if (m == MATCH_YES)
 	{
-	  name[0] = '.';
-	  strcat (name, ".");
 	  if (gfc_match (" : ") != MATCH_YES)
 	    return MATCH_ERROR;
+	  strcpy (name, oper);
 	}
       else
 	{
-- 
2.19.0.rc1

[PATCH,FORTRAN 06/29] Use stringpool for association_list

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

2017-10-26  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (struct gfc_association_list): Change name to
	pointer.
	* match.c (gfc_match_associate): Adjust.
---
 gcc/fortran/gfortran.h | 2 +-
 gcc/fortran/match.c    | 6 ++----
 2 files changed, 3 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 774a6de6168..ff42b39b453 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2482,7 +2482,7 @@ typedef struct gfc_association_list
   /* True when the rank of the target expression is guessed during parsing.  */
   unsigned rankguessed:1;
 
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   gfc_symtree *st; /* Symtree corresponding to name.  */
   locus where;
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 1b03e7251a5..38827ed4637 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1891,8 +1891,7 @@ gfc_match_associate (void)
       gfc_association_list* a;
 
       /* Match the next association.  */
-      const char *name_hack = NULL;
-      if (gfc_match (" %n =>", &name_hack) != MATCH_YES)
+      if (gfc_match (" %n =>", &newAssoc->name) != MATCH_YES)
 	{
 	  gfc_error ("Expected association at %C");
 	  goto assocListError;
@@ -1909,12 +1908,11 @@ gfc_match_associate (void)
 	    }
 	  gfc_matching_procptr_assignment = 0;
 	}
-      strcpy (newAssoc->name, name_hack);
       newAssoc->where = gfc_current_locus;
 
       /* Check that the current name is not yet in the list.  */
       for (a = new_st.ext.block.assoc; a; a = a->next)
-	if (!strcmp (a->name, newAssoc->name))
+	if (a->name == newAssoc->name)
 	  {
 	    gfc_error ("Duplicate name %qs in association at %C",
 		       newAssoc->name);
-- 
2.19.0.rc1

[PATCH,FORTRAN 01/29] gdbinit: break on gfc_internal_error

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Aids debugging the fortran FE.

gcc/ChangeLog:

2017-11-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gdbinit.in: Break on gfc_internal_error.
---
 gcc/gdbinit.in | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
index 4db977f0bab..ac4d7c42e21 100644
--- a/gcc/gdbinit.in
+++ b/gcc/gdbinit.in
@@ -227,6 +227,7 @@ b fancy_abort
 
 # Put a breakpoint on internal_error to help with debugging ICEs.
 b internal_error
+b gfc_internal_error
 
 set complaints 0
 # Don't let abort actually run, as it will make
-- 
2.19.0.rc1

[PATCH,FORTRAN 13/29] Use stringpool for intrinsics and common

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-15  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (struct gfc_common_head, struct gfc_intrinsic_arg):
	Make name a pointer.
	* intrinsic.c (add_sym): Use stringpool for name.
	* match.c (gfc_get_common): Likewise.
	* symbol.c (set_symbol_common_block): Likewise.
	* trans-common.c (gfc_sym_mangled_common_id): Likewise.
	(finish_equivalences): Likewise.
	(gfc_trans_common): Likewise.
---
 gcc/fortran/gfortran.h     |  4 ++--
 gcc/fortran/intrinsic.c    | 11 +++--------
 gcc/fortran/match.c        |  2 +-
 gcc/fortran/symbol.c       |  2 +-
 gcc/fortran/trans-common.c | 10 +++++-----
 5 files changed, 12 insertions(+), 17 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cb9195d393e..039719644ea 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1641,7 +1641,7 @@ typedef struct gfc_common_head
   char use_assoc, saved, threadprivate;
   unsigned char omp_declare_target : 1;
   unsigned char omp_declare_target_link : 1;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   struct gfc_symbol *head;
   const char* binding_label;
   int is_bind_c;
@@ -1978,7 +1978,7 @@ gfc_ref;
 /* Structures representing intrinsic symbols and their arguments lists.  */
 typedef struct gfc_intrinsic_arg
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
 
   gfc_typespec ts;
   unsigned optional:1, value:1;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 609668613a7..3a32a7824bf 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -317,7 +317,6 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
 	 int standard, gfc_check_f check, gfc_simplify_f simplify,
 	 gfc_resolve_f resolve, ...)
 {
-  char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0'  */
   int optional, first_flag;
   sym_intent intent;
   va_list argp;
@@ -334,11 +333,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
 
     case SZ_NOTHING:
       next_sym->name = gfc_get_string ("%s", name);
-
-      strcpy (buf, "_gfortran_");
-      strcat (buf, name);
-      next_sym->lib_name = gfc_get_string ("%s", buf);
-
+      next_sym->lib_name = gfc_get_string ("_gfortran_%s", name);
       next_sym->pure = (cl != CLASS_IMPURE);
       next_sym->elemental = (cl == CLASS_ELEMENTAL);
       next_sym->inquiry = (cl == CLASS_INQUIRY);
@@ -388,7 +383,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
 
 	  first_flag = 0;
 
-	  strcpy (next_arg->name, name);
+	  next_arg->name = gfc_get_string ("%s", name);
 	  next_arg->ts.type = type;
 	  next_arg->ts.kind = kind;
 	  next_arg->optional = optional;
@@ -4145,7 +4140,7 @@ keywords:
   for (; a; a = a->next)
     {
       for (f = formal; f; f = f->next)
-	if (strcmp (a->name, f->name) == 0)
+	if (a->name == f->name)
 	  break;
 
       if (f == NULL)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2c4d6e8228c..fd91e280b93 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5029,7 +5029,7 @@ gfc_get_common (const char *name, int from_module)
     {
       st->n.common = gfc_get_common_head ();
       st->n.common->where = gfc_current_locus;
-      strcpy (st->n.common->name, name);
+      st->n.common->name = name;
     }
 
   return st->n.common;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 00a178772df..cc9d4e3f9d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3057,7 +3057,7 @@ set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
   if (sym->common_block == common_block)
     return;
 
-  if (sym->common_block && sym->common_block->name[0] != '\0')
+  if (sym->common_block && sym->common_block->name != NULL)
     {
       sym->common_block->refs--;
       if (sym->common_block->refs == 0)
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index bd9721dee41..18f87e00320 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -243,16 +243,16 @@ gfc_sym_mangled_common_id (gfc_common_head *com)
 {
   int has_underscore;
   char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
 
   /* Get the name out of the common block pointer.  */
-  strcpy (name, com->name);
+  name = com->name;
 
   /* If we're suppose to do a bind(c).  */
   if (com->is_bind_c == 1 && com->binding_label)
     return get_identifier (com->binding_label);
 
-  if (strcmp (name, BLANK_COMMON_NAME) == 0)
+  if (name == gfc_get_string (BLANK_COMMON_NAME))
     return get_identifier (name);
 
   if (flag_underscoring)
@@ -1252,7 +1252,7 @@ finish_equivalences (gfc_namespace *ns)
 	      c->where = ns->proc_name->declared_at;
 	    else if (ns->is_block_data)
 	      c->where = ns->sym_root->n.sym->declared_at;
-	    strcpy (c->name, z->module);
+	    c->name = z->module;
 	  }
 	else
 	  c = NULL;
@@ -1286,7 +1286,7 @@ gfc_trans_common (gfc_namespace *ns)
     {
       c = gfc_get_common_head ();
       c->where = ns->blank_common.head->common_head->where;
-      strcpy (c->name, BLANK_COMMON_NAME);
+      c->name = gfc_get_string (BLANK_COMMON_NAME);
       translate_common (c, ns->blank_common.head);
     }
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 04/29] Use stringpool for gfc_match_generic_spec

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Ideally we would populate mstrings structs with strings obtained through
the stringpool. Doing so by means of minit wouldn't work out too well
though, see comment in gfortran.h. We could replace the initialized
strings in gfc_init_1 but that's for a later patch.

gcc/fortran/ChangeLog:

2017-10-23  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.h (gfc_match_generic_spec): Pass argument name by reference.
	Adjust all callers.
	* decl.c (access_attr_decl): Adjust.
	(gfc_match_generic): Adjust.
	* interface.c (gfc_match_generic_spec, gfc_match_interface,
	gfc_match_end_interface): Adjust.
	* module.c (gfc_match_use): Adjust.
---
 gcc/fortran/decl.c      | 11 +++++------
 gcc/fortran/gfortran.h  |  5 +++++
 gcc/fortran/interface.c | 20 +++++++++-----------
 gcc/fortran/match.h     |  3 ++-
 gcc/fortran/module.c    | 16 +++++++++-------
 5 files changed, 30 insertions(+), 25 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f0ff5138ca1..2f8d2aca695 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -8582,7 +8582,7 @@ gfc_match_target (void)
 static match
 access_attr_decl (gfc_statement st)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   interface_type type;
   gfc_user_op *uop;
   gfc_symbol *sym, *dt_sym;
@@ -10768,7 +10768,7 @@ syntax:
 match
 gfc_match_generic (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...).  */
   gfc_symbol* block;
   gfc_typebound_proc tbattr; /* Used for match_binding_attributes.  */
@@ -10931,9 +10931,8 @@ gfc_match_generic (void)
     {
       gfc_symtree* target_st;
       gfc_tbp_generic* target;
-      const char *name2 = NULL;
 
-      m = gfc_match_name (&name2);
+      m = gfc_match_name (&name);
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_NO)
@@ -10942,14 +10941,14 @@ gfc_match_generic (void)
 	  goto error;
 	}
 
-      target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name2);
+      target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
 
       /* See if this is a duplicate specification.  */
       for (target = tb->u.generic; target; target = target->next)
 	if (target_st == target->specific_st)
 	  {
 	    gfc_error ("%qs already defined as specific binding for the"
-		       " generic %qs at %C", name2, bind_name);
+		       " generic %qs at %C", name, bind_name);
 	    goto error;
 	  }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 04b0024a992..774a6de6168 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -95,6 +95,11 @@ not after.
 
 /* Macro to initialize an mstring structure.  */
 #define minit(s, t) { s, NULL, t }
+/* Ideally we would want that to be
+   { IDENTIFIER_POINTER (get_identifier_with_length (s, sizeof(s)-1)), NULL, t }
+   but stringpool's hash table is not allocated yet and we would have to do
+   tricks to have a ctor to initialize it. And even that wouldn't work too
+   well as toplevel would later on wipe ident_hash.  */
 
 /* Structure for storing strings to be matched by gfc_match_string.  */
 typedef struct
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index de58eed23f0..6a5fe928b93 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -136,11 +136,10 @@ dtio_op (char* mode)
 
 match
 gfc_match_generic_spec (interface_type *type,
-			char *name,
+			const char *&name,
 			gfc_intrinsic_op *op)
 {
   char buffer[GFC_MAX_SYMBOL_LEN + 1];
-  const char *name2 = NULL;
   match m;
   gfc_intrinsic_op i;
 
@@ -174,7 +173,7 @@ gfc_match_generic_spec (interface_type *type,
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
-      strcpy (name, oper);
+      name = oper;
       *type = INTERFACE_USER_OP;
       return MATCH_YES;
     }
@@ -184,12 +183,12 @@ gfc_match_generic_spec (interface_type *type,
       *op = dtio_op (buffer);
       if (*op == INTRINSIC_FORMATTED)
 	{
-	  strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+	  name = gfc_code2string (dtio_procs, DTIO_RF);
 	  *type = INTERFACE_DTIO;
 	}
       if (*op == INTRINSIC_UNFORMATTED)
 	{
-	  strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+	  name = gfc_code2string (dtio_procs, DTIO_RUF);
 	  *type = INTERFACE_DTIO;
 	}
       if (*op != INTRINSIC_NONE)
@@ -201,21 +200,20 @@ gfc_match_generic_spec (interface_type *type,
       *op = dtio_op (buffer);
       if (*op == INTRINSIC_FORMATTED)
 	{
-	  strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+	  name = gfc_code2string (dtio_procs, DTIO_WF);
 	  *type = INTERFACE_DTIO;
 	}
       if (*op == INTRINSIC_UNFORMATTED)
 	{
-	  strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+	  name = gfc_code2string (dtio_procs, DTIO_WUF);
 	  *type = INTERFACE_DTIO;
 	}
       if (*op != INTRINSIC_NONE)
 	return MATCH_YES;
     }
 
-  if (gfc_match_name (&name2) == MATCH_YES)
+  if (gfc_match_name (&name) == MATCH_YES)
     {
-      strcpy (name, name2);
       *type = INTERFACE_GENERIC;
       return MATCH_YES;
     }
@@ -235,7 +233,7 @@ syntax:
 match
 gfc_match_interface (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   interface_type type;
   gfc_symbol *sym;
   gfc_intrinsic_op op;
@@ -327,7 +325,7 @@ gfc_match_abstract_interface (void)
 match
 gfc_match_end_interface (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   interface_type type;
   gfc_intrinsic_op op;
   match m;
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 62554d9667e..75e0d9204d7 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -296,7 +296,8 @@ match gfc_match_array_constructor (gfc_expr **);
 
 /* interface.c.  */
 match gfc_match_abstract_interface (void);
-match gfc_match_generic_spec (interface_type *, char *, gfc_intrinsic_op *);
+match gfc_match_generic_spec (interface_type *, const char *&,
+    gfc_intrinsic_op *);
 match gfc_match_interface (void);
 match gfc_match_end_interface (void);
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index f31677b3b5e..1064f3c80cb 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -68,9 +68,9 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "options.h"
+#include "stringpool.h"
 #include "tree.h"
 #include "gfortran.h"
-#include "stringpool.h"
 #include "arith.h"
 #include "match.h"
 #include "parse.h" /* FIXME */
@@ -519,8 +519,8 @@ free_rename (gfc_use_rename *list)
 match
 gfc_match_use (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
-  const char *name2 = NULL;
+  char module_nature[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_use_rename *tail = NULL, *new_use;
   interface_type type, type2;
   gfc_intrinsic_op op;
@@ -584,14 +584,14 @@ gfc_match_use (void)
 
   use_list->where = gfc_current_locus;
 
-  m = gfc_match_name (&name2);
+  m = gfc_match_name (&name);
   if (m != MATCH_YES)
     {
       free (use_list);
       return m;
     }
 
-  use_list->module_name = name2;
+  use_list->module_name = name;
 
   if (gfc_match_eos () == MATCH_YES)
     goto done;
@@ -650,13 +650,14 @@ gfc_match_use (void)
 	      else
 		{
 		  strcpy (new_use->local_name, name);
-		  m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+		  m = gfc_match_generic_spec (&type2, name, &op);
 		  if (type != type2)
 		    goto syntax;
 		  if (m == MATCH_NO)
 		    goto syntax;
 		  if (m == MATCH_ERROR)
 		    goto cleanup;
+		  strcpy (new_use->use_name, name);
 		}
 	    }
 	  else
@@ -665,13 +666,14 @@ gfc_match_use (void)
 		goto syntax;
 	      strcpy (new_use->local_name, name);
 
-	      m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+	      m = gfc_match_generic_spec (&type2, name, &op);
 	      if (type != type2)
 		goto syntax;
 	      if (m == MATCH_NO)
 		goto syntax;
 	      if (m == MATCH_ERROR)
 		goto cleanup;
+	      strcpy (new_use->use_name, name);
 	    }
 
 	  if (strcmp (new_use->use_name, use_list->module_name) == 0
-- 
2.19.0.rc1

[PATCH,FORTRAN 09/29] Use stringpool for modules

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-10-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (struct gfc_use_rename): Use pointers for
	local_name and use_name.
	* match.c (gfc_match): Set name to NULL on failed match.
	* module.c (gfc_match_use): Use pointer comparison instead of
	string comparison.
	(find_use_name_n): Likewise.
	(mio_internal_string): Delete.
	(mio_expr): Simplify INTRINSIC_USER handling.
	(load_operator_interfaces): Use pointer for name and module.
	(load_generic_interfaces): Likewise.
	(load_commons): Use pointer for name.
	(load_needed): Use pointer comparison instead of string
	comparison.
	(read_module): Use pointer for name. Use pointer comparison
	instead if string comparison.
	(import_iso_c_binding_module): Adjust to struct gfc_use_rename
	changes.
	(use_iso_fortran_env_module): Likewise.
	* symbol.c (generate_isocbinding_symbol): Likewise.
	* trans-decl.c (gfc_trans_use_stmts): Likewise.
---
 gcc/fortran/gfortran.h   |   3 +-
 gcc/fortran/match.c      |  11 +++-
 gcc/fortran/module.c     | 115 ++++++++++++++-------------------------
 gcc/fortran/symbol.c     |   2 +-
 gcc/fortran/trans-decl.c |   8 +--
 5 files changed, 56 insertions(+), 83 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6c32b8ac71f..cb9195d393e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1673,7 +1673,8 @@ gfc_entry_list;
 
 typedef struct gfc_use_rename
 {
-  char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *local_name;
+  const char *use_name;
   struct gfc_use_rename *next;
   int found;
   gfc_intrinsic_op op;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 38827ed4637..6596bd87c09 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1274,15 +1274,22 @@ not_yes:
 	    case '%':
 	      matches++;
 	      break;		/* Skip.  */
+#if 0
+	    /* If everybody is disciplined we do not need to reset this.  */
+	    case 'n':
+	      vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't be */
+	      *vp = NULL;
+	      break;
+#else
+	    case 'n':
+#endif
 
 	    /* Matches that don't have to be undone */
 	    case 'o':
 	    case 'l':
-	    case 'n':
 	    case 's':
 	      (void) va_arg (argp, void **);
 	      break;
-
 	    case 'e':
 	    case 'v':
 	      vp = va_arg (argp, void **);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b3f68b8803f..3ad47f57930 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -646,10 +646,10 @@ gfc_match_use (void)
 	  if (use_list->only_flag)
 	    {
 	      if (m != MATCH_YES)
-		strcpy (new_use->use_name, name);
+		new_use->use_name = name;
 	      else
 		{
-		  strcpy (new_use->local_name, name);
+		  new_use->local_name = name;
 		  m = gfc_match_generic_spec (&type2, name, &op);
 		  if (type != type2)
 		    goto syntax;
@@ -657,15 +657,14 @@ gfc_match_use (void)
 		    goto syntax;
 		  if (m == MATCH_ERROR)
 		    goto cleanup;
-		  strcpy (new_use->use_name, name);
+		  new_use->use_name = name;
 		}
 	    }
 	  else
 	    {
 	      if (m != MATCH_YES)
 		goto syntax;
-	      strcpy (new_use->local_name, name);
-
+	      new_use->local_name = name;
 	      m = gfc_match_generic_spec (&type2, name, &op);
 	      if (type != type2)
 		goto syntax;
@@ -673,11 +672,11 @@ gfc_match_use (void)
 		goto syntax;
 	      if (m == MATCH_ERROR)
 		goto cleanup;
-	      strcpy (new_use->use_name, name);
+	      new_use->use_name = name;
 	    }
 
-	  if (strcmp (new_use->use_name, use_list->module_name) == 0
-	      || strcmp (new_use->local_name, use_list->module_name) == 0)
+	  if (new_use->use_name == use_list->module_name
+	      || new_use->local_name == use_list->module_name)
 	    {
 	      gfc_error ("The name %qs at %C has already been used as "
 			 "an external module name", use_list->module_name);
@@ -848,8 +847,8 @@ find_use_name_n (const char *name, int *inst, bool interface)
   i = 0;
   for (u = gfc_rename_list; u; u = u->next)
     {
-      if ((!low_name && strcmp (u->use_name, name) != 0)
-	  || (low_name && strcmp (u->use_name, low_name) != 0)
+      if ((!low_name && u->use_name != name)
+	  || (low_name && u->use_name != low_name)
 	  || (u->op == INTRINSIC_USER && !interface)
 	  || (u->op != INTRINSIC_USER &&  interface))
 	continue;
@@ -870,12 +869,11 @@ find_use_name_n (const char *name, int *inst, bool interface)
 
   if (low_name)
     {
-      if (u->local_name[0] == '\0')
+      if (u->local_name == NULL)
 	return name;
       return gfc_dt_upper_string (u->local_name);
     }
-
-  return (u->local_name[0] != '\0') ? u->local_name : name;
+  return u->local_name != NULL ? u->local_name : name;
 }
 
 
@@ -1980,24 +1978,6 @@ mio_pool_string (const char **stringp)
     }
 }
 
-
-/* Read or write a string that is inside of some already-allocated
-   structure.  */
-
-static void
-mio_internal_string (char *string)
-{
-  if (iomode == IO_OUTPUT)
-    write_atom (ATOM_STRING, string);
-  else
-    {
-      require_atom (ATOM_STRING);
-      strcpy (string, atom_string);
-      free (atom_string);
-    }
-}
-
-
 enum ab_attribute
 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
@@ -3536,20 +3516,12 @@ mio_expr (gfc_expr **ep)
 	    write_atom (ATOM_STRING, e->value.op.uop->name);
 	  else
 	    {
-	      char *name = read_string ();
+	      const char *name;
+	      mio_pool_string (&name);
 	      const char *uop_name = find_use_name (name, true);
 	      if (uop_name == NULL)
-		{
-		  size_t len = strlen (name);
-		  char *name2 = XCNEWVEC (char, len + 2);
-		  memcpy (name2, name, len);
-		  name2[len] = ' ';
-		  name2[len + 1] = '\0';
-		  free (name);
-		  uop_name = name = name2;
-		}
+		uop_name = name = gfc_get_string ("%s ", name);
 	      e->value.op.uop = gfc_get_uop (uop_name);
-	      free (name);
 	    }
 	  mio_expr (&e->value.op.op1);
 	  mio_expr (&e->value.op.op2);
@@ -4481,7 +4453,7 @@ static void
 load_operator_interfaces (void)
 {
   const char *p;
-  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL, *module = NULL;
   gfc_user_op *uop;
   pointer_info *pi = NULL;
   int n, i;
@@ -4492,8 +4464,8 @@ load_operator_interfaces (void)
     {
       mio_lparen ();
 
-      mio_internal_string (name);
-      mio_internal_string (module);
+      mio_pool_string (&name);
+      mio_pool_string (&module);
 
       n = number_use_names (name, true);
       n = n ? n : 1;
@@ -4537,7 +4509,7 @@ static void
 load_generic_interfaces (void)
 {
   const char *p;
-  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL, *module = NULL;
   gfc_symbol *sym;
   gfc_interface *generic = NULL, *gen = NULL;
   int n, i, renamed;
@@ -4549,8 +4521,8 @@ load_generic_interfaces (void)
     {
       mio_lparen ();
 
-      mio_internal_string (name);
-      mio_internal_string (module);
+      mio_pool_string (&name);
+      mio_pool_string (&module);
 
       n = number_use_names (name, false);
       renamed = n ? 1 : 0;
@@ -4667,7 +4639,7 @@ load_generic_interfaces (void)
 static void
 load_commons (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_common_head *p;
 
   mio_lparen ();
@@ -4677,7 +4649,7 @@ load_commons (void)
       int flags;
       char* label;
       mio_lparen ();
-      mio_internal_string (name);
+      mio_pool_string (&name);
 
       p = gfc_get_common (name, 1);
 
@@ -4955,7 +4927,7 @@ load_needed (pointer_info *p)
 	 found, mark it.  */
       for (u = gfc_rename_list; u; u = u->next)
 	{
-	  if (strcmp (u->use_name, sym->name) == 0)
+	  if (u->use_name == sym->name)
 	    {
 	      sym->attr.use_only = 1;
 	      break;
@@ -5073,7 +5045,7 @@ read_module (void)
 {
   module_locus operator_interfaces, user_operators, omp_udrs;
   const char *p;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   int i;
   /* Workaround -Wmaybe-uninitialized false positive during
      profiledbootstrap by initializing them.  */
@@ -5197,7 +5169,7 @@ read_module (void)
 
   while (peek_atom () != ATOM_RPAREN)
     {
-      mio_internal_string (name);
+      mio_pool_string (&name);
       mio_integer (&ambiguous);
       mio_integer (&symbol);
 
@@ -5216,7 +5188,7 @@ read_module (void)
 	  /* Get the jth local name for this symbol.  */
 	  p = find_use_name_n (name, &j, false);
 
-	  if (p == NULL && strcmp (name, module_name) == 0)
+	  if (p == NULL && name == module_name)
 	    p = name;
 
 	  /* Exception: Always import vtabs & vtypes.  */
@@ -5246,7 +5218,7 @@ read_module (void)
 	     added to the namespace(11.3.2).  Note that find_symbol
 	     only returns the first occurrence that it finds.  */
 	  if (!only_flag && !info->u.rsym.renamed
-		&& strcmp (name, module_name) != 0
+		&& name != module_name
 		&& find_symbol (gfc_current_ns->sym_root, name,
 				module_name, 0))
 	    continue;
@@ -5303,7 +5275,7 @@ read_module (void)
 	      st->n.sym = sym;
 	      st->n.sym->refs++;
 
-	      if (strcmp (name, p) != 0)
+	      if (name != p)
 		sym->attr.use_rename = 1;
 
 	      if (name[0] != '_'
@@ -6349,22 +6321,15 @@ import_iso_c_binding_module (void)
                        u->use_name) == 0)
 	{
 	  c_ptr = generate_isocbinding_symbol (iso_c_module_name,
-                                               (iso_c_binding_symbol)
-							ISOCBINDING_PTR,
-                                               u->local_name[0] ? u->local_name
-                                                                : u->use_name,
-                                               NULL, false);
+	      (iso_c_binding_symbol) ISOCBINDING_PTR,
+	      u->local_name ? u->local_name : u->use_name, NULL, false);
 	}
       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
                        u->use_name) == 0)
 	{
-	  c_funptr
-	     = generate_isocbinding_symbol (iso_c_module_name,
-					    (iso_c_binding_symbol)
-							ISOCBINDING_FUNPTR,
-					     u->local_name[0] ? u->local_name
-							      : u->use_name,
-					     NULL, false);
+	  c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+	      (iso_c_binding_symbol) ISOCBINDING_FUNPTR,
+	       u->local_name ? u->local_name : u->use_name, NULL, false);
 	}
     }
 
@@ -6442,7 +6407,7 @@ import_iso_c_binding_module (void)
 		    return_type = c_funptr->n.sym; \
 		  else \
 		    return_type = NULL; \
-		  create_intrinsic_function (u->local_name[0] \
+		  create_intrinsic_function (u->local_name \
 					     ? u->local_name : u->use_name, \
 					     a, iso_c_module_name, \
 					     INTMOD_ISO_C_BINDING, false, \
@@ -6450,7 +6415,7 @@ import_iso_c_binding_module (void)
 		  break;
 #define NAMED_SUBROUTINE(a,b,c,d) \
 	        case a: \
-		  create_intrinsic_function (u->local_name[0] ? u->local_name \
+		  create_intrinsic_function (u->local_name ? u->local_name \
 							      : u->use_name, \
                                              a, iso_c_module_name, \
                                              INTMOD_ISO_C_BINDING, true, NULL); \
@@ -6470,7 +6435,7 @@ import_iso_c_binding_module (void)
 		    tmp_symtree = NULL;
 		  generate_isocbinding_symbol (iso_c_module_name,
 					       (iso_c_binding_symbol) i,
-					       u->local_name[0]
+					       u->local_name
 					       ? u->local_name : u->use_name,
 					       tmp_symtree, false);
 	      }
@@ -6790,7 +6755,7 @@ use_iso_fortran_env_module (void)
 #define NAMED_INTCST(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
-		  create_int_parameter (u->local_name[0] ? u->local_name
+		  create_int_parameter (u->local_name ? u->local_name
 							 : u->use_name,
 					symbol[i].value, mod,
 					INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
@@ -6805,7 +6770,7 @@ use_iso_fortran_env_module (void)
 		    gfc_constructor_append_expr (&expr->value.constructor, \
 			gfc_get_int_expr (gfc_default_integer_kind, NULL, \
 					  KINDS[j].kind), NULL); \
-		  create_int_parameter_array (u->local_name[0] ? u->local_name \
+		  create_int_parameter_array (u->local_name ? u->local_name \
 							 : u->use_name, \
 					      j, expr, mod, \
 					      INTMOD_ISO_FORTRAN_ENV, \
@@ -6816,7 +6781,7 @@ use_iso_fortran_env_module (void)
 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
 		case a:
 #include "iso-fortran-env.def"
-                  create_derived_type (u->local_name[0] ? u->local_name
+                  create_derived_type (u->local_name ? u->local_name
 							: u->use_name,
 				       mod, INTMOD_ISO_FORTRAN_ENV,
 				       symbol[i].id);
@@ -6825,7 +6790,7 @@ use_iso_fortran_env_module (void)
 #define NAMED_FUNCTION(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
-		  create_intrinsic_function (u->local_name[0] ? u->local_name
+		  create_intrinsic_function (u->local_name ? u->local_name
 							      : u->use_name,
 					     symbol[i].id, mod,
 					     INTMOD_ISO_FORTRAN_ENV, false,
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index a8f841185f1..e576bc1cb69 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4761,7 +4761,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 			     const char *local_name, gfc_symtree *dt_symtree,
 			     bool hidden)
 {
-  const char *const name = (local_name && local_name[0])
+  const char *const name = local_name
 			   ? local_name : c_interop_kinds_table[s].name;
   gfc_symtree *tmp_symtree;
   gfc_symbol *tmp_sym = NULL;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index eea6b81ebfa..e2adfa2e2db 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5040,7 +5040,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	  if (rent->op != INTRINSIC_NONE)
 	    continue;
 
-						 hashval_t hash = htab_hash_string (rent->use_name);
+	  hashval_t hash = htab_hash_string (rent->use_name);
 	  tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
 							  INSERT);
 	  if (*slot == NULL)
@@ -5048,14 +5048,14 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      gfc_symtree *st;
 
 	      st = gfc_find_symtree (ns->sym_root,
-				     rent->local_name[0]
+				     rent->local_name
 				     ? rent->local_name : rent->use_name);
 
 	      /* The following can happen if a derived type is renamed.  */
 	      if (!st)
 		{
 		  char *name;
-		  name = xstrdup (rent->local_name[0]
+		  name = xstrdup (rent->local_name
 				  ? rent->local_name : rent->use_name);
 		  name[0] = (char) TOUPPER ((unsigned char) name[0]);
 		  st = gfc_find_symtree (ns->sym_root, name);
@@ -5102,7 +5102,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      *slot = decl;
 	    }
 	  decl = (tree) *slot;
-	  if (rent->local_name[0])
+	  if (rent->local_name)
 	    local_name = get_identifier (rent->local_name);
 	  else
 	    local_name = NULL_TREE;
-- 
2.19.0.rc1

[PATCH,FORTRAN 12/29] Use stringpool for remaining names

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

This replaces the remaining occurrences of names and name manipulation
to go through the stringpool. Required to make TYPE (IS) handling work
later on.

gcc/fortran/ChangeLog:

2017-11-14  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* class.c (gfc_build_class_symbol): Use pointer for name.
	(generate_finalization_wrapper): Likewise.
	(gfc_find_derived_vtab): Likewise.
	(find_intrinsic_vtab): Likewise.
	* decl.c (gfc_get_pdt_instance): Likewise.
	* frontend-passes.c (create_do_loop): Likewise.
	* match.c (select_intrinsic_set_tmp): Likewise.
	* resolve.c (resolve_select_type): Likewise.
	(resolve_critical): Likewise.
	(get_temp_from_expr): Likewise.
	(resolve_component): Likewise.
	* trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment):
	Likewise.
	* trans.c (gfc_deferred_strlen): Likewise.
---
 gcc/fortran/class.c           | 44 ++++++++++++++++-------------------
 gcc/fortran/decl.c            |  2 +-
 gcc/fortran/frontend-passes.c |  6 ++---
 gcc/fortran/match.c           |  6 ++---
 gcc/fortran/resolve.c         | 30 +++++++++++-------------
 gcc/fortran/trans-expr.c      |  4 ++--
 gcc/fortran/trans.c           |  6 ++---
 7 files changed, 46 insertions(+), 52 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8e637689fae..c2dc3411811 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -602,7 +602,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 			gfc_array_spec **as)
 {
   char tname[GFC_MAX_SYMBOL_LEN+1];
-  char *name;
+  const char *name;
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
@@ -633,17 +633,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && attr->allocatable)
-    name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank);
   else if ((*as) && attr->pointer)
-    name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
   else if ((*as))
-    name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
   else if (attr->pointer)
-    name = xasprintf ("__class_%s_p", tname);
+    name = gfc_get_string ("__class_%s_p", tname);
   else if (attr->allocatable)
-    name = xasprintf ("__class_%s_a", tname);
+    name = gfc_get_string ("__class_%s_a", tname);
   else
-    name = xasprintf ("__class_%s_t", tname);
+    name = gfc_get_string ("__class_%s_t", tname);
 
   if (ts->u.derived->attr.unlimited_polymorphic)
     {
@@ -738,7 +738,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   ts->u.derived = fclass;
   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
   (*as) = NULL;
-  free (name);
   return true;
 }
 
@@ -1528,7 +1527,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code, *block;
-  char *name;
+  const char *name;
   bool finalizable_comp = false;
   bool expr_null_wrapper = false;
   gfc_expr *ancestor_wrapper = NULL, *rank;
@@ -1607,7 +1606,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
-  name = xasprintf ("__final_%s", tname);
+  name = gfc_get_string ("__final_%s", tname);
   gfc_get_symbol (name, sub_ns, &final);
   sub_ns->proc_name = final;
   final->attr.flavor = FL_PROCEDURE;
@@ -2173,7 +2172,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_free_expr (rank);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
-  free (name);
 }
 
 
@@ -2242,10 +2240,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       get_unique_hashed_string (tname, derived);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */
       if (gsym && gsym->ns)
@@ -2273,7 +2271,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2376,7 +2374,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      else
 		{
 		  /* Construct default initialization variable.  */
-		  name = xasprintf ("__def_init_%s", tname);
+		  name = gfc_get_string ("__def_init_%s", tname);
 		  gfc_get_symbol (name, ns, &def_init);
 		  def_init->attr.target = 1;
 		  def_init->attr.artificial = 1;
@@ -2409,7 +2407,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__copy_%s", tname);
+		  name = gfc_get_string ("__copy_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &copy);
 		  sub_ns->proc_name = copy;
 		  copy->attr.flavor = FL_PROCEDURE;
@@ -2486,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__deallocate_%s", tname);
+		  name = gfc_get_string ("__deallocate_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &dealloc);
 		  sub_ns->proc_name = dealloc;
 		  dealloc->attr.flavor = FL_PROCEDURE;
@@ -2535,7 +2533,6 @@ have_vtype:
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
@@ -2628,13 +2625,13 @@ find_intrinsic_vtab (gfc_typespec *ts)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       /* Encode all types as TYPENAME_KIND_ including especially character
 	 arrays, whose length is now consistently stored in the _len component
 	 of the class-variable.  */
       sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in the top-level namespace only.  */
       gfc_find_symbol (name, ns, 0, &vtab);
@@ -2651,7 +2648,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2727,12 +2724,12 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->tb->ppc = 1;
 
 	      if (ts->type != BT_CHARACTER)
-		name = xasprintf ("__copy_%s", tname);
+		name = gfc_get_string ("__copy_%s", tname);
 	      else
 		{
 		  /* __copy is always the same for characters.
 		     Check to see if copy function already exists.  */
-		  name = xasprintf ("__copy_character_%d", ts->kind);
+		  name = gfc_get_string ("__copy_character_%d", ts->kind);
 		  contained = ns->contained;
 		  for (; contained; contained = contained->sibling)
 		    if (contained->proc_name
@@ -2801,7 +2798,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2baa1783434..48ef5637e36 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3582,7 +3582,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 
   /* Now we search for the PDT instance 'name'. If it doesn't exist, we
      build it, using 'pdt' as a template.  */
-  if (gfc_get_symbol (name, pdt->ns, &instance))
+  if (gfc_get_symbol (gfc_get_string ("%s", name), pdt->ns, &instance))
     {
       gfc_error ("Parameterized derived type at %C is ambiguous");
       goto error_return;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 0a5e8937015..d549d8b6ffd 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -3427,7 +3427,7 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
 		gfc_namespace *ns, char *vname)
 {
 
-  char name[GFC_MAX_SYMBOL_LEN +1];
+  const char *name;
   gfc_symtree *symtree;
   gfc_symbol *symbol;
   gfc_expr *i;
@@ -3435,9 +3435,9 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
 
   /* Create an expression for the iteration variable.  */
   if (vname)
-    sprintf (name, "__var_%d_do_%s", var_num++, vname);
+    name = gfc_get_string ("__var_%d_do_%s", var_num++, vname);
   else
-    sprintf (name, "__var_%d_do", var_num++);
+    name = gfc_get_string ("__var_%d_do", var_num++);
 
 
   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f27249ec6ed..2c4d6e8228c 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -6048,7 +6048,7 @@ select_type_push (gfc_symbol *sel)
 static gfc_symtree *
 select_intrinsic_set_tmp (gfc_typespec *ts)
 {
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name;
   gfc_symtree *tmp;
   HOST_WIDE_INT charlen = 0;
 
@@ -6064,10 +6064,10 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
     charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
 
   if (ts->type != BT_CHARACTER)
-    sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
+    name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (ts->type),
 	     ts->kind);
   else
-    snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+    name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
 	      gfc_basic_typename (ts->type), charlen, ts->kind);
 
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index afb745bddc5..e98e6a6d53e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8842,7 +8842,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   gfc_code *class_is = NULL, *default_case = NULL;
   gfc_case *c;
   gfc_symtree *st;
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name;
   gfc_namespace *ns;
   int error = 0;
   int rank = 0;
@@ -9096,21 +9096,20 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	 'global' one).  */
 
       if (c->ts.type == BT_CLASS)
-	sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+	name = gfc_get_string ("__tmp_class_%s", c->ts.u.derived->name);
       else if (c->ts.type == BT_DERIVED)
-	sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+	name = gfc_get_string ("__tmp_type_%s", c->ts.u.derived->name);
       else if (c->ts.type == BT_CHARACTER)
 	{
 	  HOST_WIDE_INT charlen = 0;
 	  if (c->ts.u.cl && c->ts.u.cl->length
 	      && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
 	    charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
-	  snprintf (name, sizeof (name),
-		    "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+	  name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
 		    gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
 	}
       else
-	sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
+	name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (c->ts.type),
 	         c->ts.kind);
 
       st = gfc_find_symtree (ns->sym_root, name);
@@ -9553,20 +9552,19 @@ resolve_critical (gfc_code *code)
 {
   gfc_symtree *symtree;
   gfc_symbol *lock_type;
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name;
   static int serial = 0;
 
   if (flag_coarray != GFC_FCOARRAY_LIB)
     return;
 
-  symtree = gfc_find_symtree (gfc_current_ns->sym_root,
-			      GFC_PREFIX ("lock_type"));
+  name = gfc_get_string (GFC_PREFIX ("lock_type"));
+  symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
   if (symtree)
     lock_type = symtree->n.sym;
   else
     {
-      if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
-			    false) != 0)
+      if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
 	gcc_unreachable ();
       lock_type = symtree->n.sym;
       lock_type->attr.flavor = FL_DERIVED;
@@ -9575,7 +9573,7 @@ resolve_critical (gfc_code *code)
       lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
     }
 
-  sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
+  name = gfc_get_string (GFC_PREFIX ("lock_var") "%d", serial++);
   if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
     gcc_unreachable ();
 
@@ -10569,13 +10567,13 @@ static gfc_expr*
 get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
 {
   static int serial = 0;
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name;
   gfc_symtree *tmp;
   gfc_array_spec *as;
   gfc_array_ref *aref;
   gfc_ref *ref;
 
-  sprintf (name, GFC_PREFIX("DA%d"), serial++);
+  name = gfc_get_string (GFC_PREFIX("DA%d"), serial++);
   gfc_get_sym_tree (name, ns, &tmp, false);
   gfc_add_type (tmp->n.sym, &e->ts, NULL);
 
@@ -13956,9 +13954,9 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
       && !c->attr.function
       && !sym->attr.is_class)
     {
-      char name[GFC_MAX_SYMBOL_LEN+9];
+      const char *name;
       gfc_component *strlen;
-      sprintf (name, "_%s_length", c->name);
+      name = gfc_get_string ("_%s_length", c->name);
       strlen = gfc_find_component (sym, name, true, true, NULL);
       if (strlen == NULL)
         {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6c8a5b30568..d502c127951 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7307,7 +7307,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 
   if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
     {
-      char name[GFC_MAX_SYMBOL_LEN+9];
+      const char *name;
       gfc_component *strlen;
       /* Use the rhs string length and the lhs element size.  */
       gcc_assert (expr2->ts.type == BT_CHARACTER);
@@ -7321,7 +7321,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 
       /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
 	 component.  */
-      sprintf (name, "_%s_length", cm->name);
+      name = gfc_get_string ("_%s_length", cm->name);
       strlen = gfc_find_component (sym, name, true, true, NULL);
       lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
 				     gfc_charlen_type_node,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 153bab63396..66ba0572e0c 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -2330,14 +2330,14 @@ gfc_likely (tree cond, enum br_predictor predictor)
 bool
 gfc_deferred_strlen (gfc_component *c, tree *decl)
 {
-  char name[GFC_MAX_SYMBOL_LEN+9];
+  const char *name;
   gfc_component *strlen;
   if (!(c->ts.type == BT_CHARACTER
 	&& (c->ts.deferred || c->attr.pdt_string)))
     return false;
-  sprintf (name, "_%s_length", c->name);
+  name = gfc_get_string ("_%s_length", c->name);
   for (strlen = c; strlen; strlen = strlen->next)
-    if (strcmp (strlen->name, name) == 0)
+    if (strlen->name == name)
       break;
   *decl = strlen ? strlen->backend_decl : NULL_TREE;
   return strlen != NULL;
-- 
2.19.0.rc1

[PATCH,FORTRAN 05/29] Use stringpool for gfc_match("%n")

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Add matched names into the stringpool.

gcc/fortran/ChangeLog:

2017-10-26  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.c (gfc_match): Use pointer to pointer when matching a
	name via "%n" format. Adjust all callers.
	(gfc_match_label, gfc_match_iterator, gfc_match_char,
	gfc_match_associate, match_derived_type_spec, gfc_match_type_spec,
	match_exit_cycle, gfc_match_allocate, gfc_match_call,
	gfc_match_block_data, select_type_set_tmp,
	gfc_match_select_type): Adjust.
	* decl.c (gfc_match_null, match_record_decl, gfc_match_decl_type_spec,
	gfc_match_implicit_none, gfc_match_import, gfc_match_function_decl,
	gfc_match_subroutine, gfc_match_save, gfc_match_submod_proc,
	check_extended_derived_type, gfc_get_type_attr_spec,
	gfc_match_structure_decl, gfc_match_derived_decl,
	match_binding_attributes): Adjust.
	* interface.c (dtio_op, gfc_match_generic_spec): Adjust.
	* io.c (match_dt_element): Adjust.
	* matchexp.c (gfc_match_defined_op_name): Adjust.
	* module.c (gfc_match_use, gfc_match_submodule): Adjust.
	* primary.c (match_arg_list_function, gfc_match_rvalue): Adjust.
	* openmp.c (gfc_match_omp_variable_list, gfc_match_omp_to_link,
	gfc_match_oacc_clause_link, match_udr_expr,
	gfc_match_omp_declare_reduction, gfc_match_omp_threadprivate): Adjust.
	(gfc_match_omp_critical): Adjust. Do not strdup critical_name.
	(gfc_free_omp_clauses): Do not free critical_name.
	(gfc_match_omp_end_critical): Adjust. Do not strdup omp_name.
	* parse.c (parse_omp_structured_block): Do not free omp_name.
	(match_deferred_characteristics): Adjust.
---
 gcc/fortran/decl.c      | 81 ++++++++++++++++++++---------------------
 gcc/fortran/interface.c | 11 +++---
 gcc/fortran/io.c        |  4 +-
 gcc/fortran/match.c     | 62 +++++++++++++++----------------
 gcc/fortran/matchexp.c  |  4 +-
 gcc/fortran/module.c    | 12 +++---
 gcc/fortran/openmp.c    | 70 ++++++++++++++++-------------------
 gcc/fortran/parse.c     |  5 +--
 gcc/fortran/primary.c   |  8 ++--
 9 files changed, 123 insertions(+), 134 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2f8d2aca695..2667c2281f8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2169,16 +2169,16 @@ gfc_match_null (gfc_expr **result)
   if (m == MATCH_NO)
     {
       locus old_loc;
-      char name[GFC_MAX_SYMBOL_LEN + 1];
+      const char *name = NULL;
 
       if ((m2 = gfc_match (" null (")) != MATCH_YES)
 	return m2;
 
       old_loc = gfc_current_locus;
-      if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
+      if ((m2 = gfc_match (" %n ) ", &name)) == MATCH_ERROR)
 	return MATCH_ERROR;
       if (m2 != MATCH_YES
-	  && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
+	  && ((m2 = gfc_match (" mold = %n )", &name)) == MATCH_ERROR))
 	return MATCH_ERROR;
       if (m2 == MATCH_NO)
 	{
@@ -3307,7 +3307,7 @@ done:
 /* Matches a RECORD declaration. */
 
 static match
-match_record_decl (char *name)
+match_record_decl (const char **name)
 {
     locus old_loc;
     old_loc = gfc_current_locus;
@@ -3824,7 +3824,7 @@ error_return:
 match
 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym, *dt_sym;
   match m;
   char c;
@@ -3883,7 +3883,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	  return MATCH_YES;
 	}
 
-      m = gfc_match ("%n", name);
+      m = gfc_match ("%n", &name);
       matched_type = (m == MATCH_YES);
     }
 
@@ -3989,7 +3989,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
     }
 
   if (m != MATCH_YES)
-    m = match_record_decl (name);
+    m = match_record_decl (&name);
 
   if (matched_type || m == MATCH_YES)
     {
@@ -4011,7 +4011,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	    return m;
 	  gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
 	  ts->u.derived = sym;
-	  strcpy (name, gfc_dt_lower_string (sym->name));
+	  name = gfc_dt_lower_string (sym->name);
 	}
 
       if (sym && sym->attr.flavor == FL_STRUCT)
@@ -4085,7 +4085,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       m = gfc_match (" class (");
 
       if (m == MATCH_YES)
-	m = gfc_match ("%n", name);
+	m = gfc_match ("%n", &name);
       else
 	return m;
 
@@ -4190,7 +4190,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	return m;
       gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
       ts->u.derived = sym;
-      strcpy (name, gfc_dt_lower_string (sym->name));
+      name = gfc_dt_lower_string (sym->name);
     }
 
   gfc_save_symbol_data (sym);
@@ -4306,7 +4306,7 @@ gfc_match_implicit_none (void)
 {
   char c;
   match m;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   bool type = false;
   bool external = false;
   locus cur_loc = gfc_current_locus;
@@ -4335,7 +4335,7 @@ gfc_match_implicit_none (void)
       else
 	for(;;)
 	  {
-	    m = gfc_match (" %n", name);
+	    m = gfc_match (" %n", &name);
 	    if (m != MATCH_YES)
 	      return MATCH_ERROR;
 
@@ -4589,7 +4589,7 @@ error:
 match
 gfc_match_import (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   match m;
   gfc_symbol *sym;
   gfc_symtree *st;
@@ -4631,7 +4631,7 @@ gfc_match_import (void)
   for(;;)
     {
       sym = NULL;
-      m = gfc_match (" %n", name);
+      m = gfc_match (" %n", &name);
       switch (m)
 	{
 	case MATCH_YES:
@@ -6969,7 +6969,7 @@ do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
 match
 gfc_match_function_decl (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym, *result;
   locus old_loc;
   match m;
@@ -6992,7 +6992,7 @@ gfc_match_function_decl (void)
       return m;
     }
 
-  if (gfc_match ("function% %n", name) != MATCH_YES)
+  if (gfc_match ("function% %n", &name) != MATCH_YES)
     {
       gfc_current_locus = old_loc;
       return MATCH_NO;
@@ -7438,7 +7438,7 @@ gfc_match_entry (void)
 match
 gfc_match_subroutine (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   match is_bind_c;
@@ -7454,7 +7454,7 @@ gfc_match_subroutine (void)
   if (m != MATCH_YES)
     return m;
 
-  m = gfc_match ("subroutine% %n", name);
+  m = gfc_match ("subroutine% %n", &name);
   if (m != MATCH_YES)
     return m;
 
@@ -9036,7 +9036,7 @@ syntax:
 match
 gfc_match_save (void)
 {
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_common_head *c;
   gfc_symbol *sym;
   match m;
@@ -9081,13 +9081,13 @@ gfc_match_save (void)
 	  return MATCH_ERROR;
 	}
 
-      m = gfc_match (" / %n /", &n);
+      m = gfc_match (" / %n /", &name);
       if (m == MATCH_ERROR)
 	return MATCH_ERROR;
       if (m == MATCH_NO)
 	goto syntax;
 
-      c = gfc_get_common (n, 0);
+      c = gfc_get_common (name, 0);
       c->saved = 1;
 
       gfc_current_ns->seen_save = 1;
@@ -9288,7 +9288,7 @@ syntax:
 match
 gfc_match_submod_proc (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym, *fsym;
   match m;
   gfc_formal_arglist *formal, *head, *tail;
@@ -9299,7 +9299,7 @@ gfc_match_submod_proc (void)
 	       || gfc_state_stack->previous->state == COMP_MODULE)))
     return MATCH_NO;
 
-  m = gfc_match (" module% procedure% %n", name);
+  m = gfc_match (" module% procedure% %n", &name);
   if (m != MATCH_YES)
     return m;
 
@@ -9497,7 +9497,7 @@ syntax:
 /* Check a derived type that is being extended.  */
 
 static gfc_symbol*
-check_extended_derived_type (char *name)
+check_extended_derived_type (const char * const name)
 {
   gfc_symbol *extended;
 
@@ -9548,7 +9548,7 @@ check_extended_derived_type (char *name)
    checking on attribute conflicts needs to be done.  */
 
 match
-gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
+gfc_get_type_attr_spec (symbol_attribute *attr, const char **name)
 {
   /* See if the derived type is marked as private.  */
   if (gfc_match (" , private") == MATCH_YES)
@@ -9594,7 +9594,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
       if (!gfc_add_abstract (attr, &gfc_current_locus))
 	return MATCH_ERROR;
     }
-  else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
+  else if (gfc_match (" , extends ( %n )", name) == MATCH_YES)
     {
       if (!gfc_add_extension (attr, &gfc_current_locus))
 	return MATCH_ERROR;
@@ -9748,7 +9748,7 @@ gfc_match_structure_decl (void)
 {
   /* Counter used to give unique internal names to anonymous structures.  */
   static unsigned int gfc_structure_id = 0;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   locus where;
@@ -9761,9 +9761,7 @@ gfc_match_structure_decl (void)
       return MATCH_ERROR;
     }
 
-  name[0] = '\0';
-
-  m = gfc_match (" /%n/", name);
+  m = gfc_match (" /%n/", &name);
   if (m != MATCH_YES)
     {
       /* Non-nested structure declarations require a structure name.  */
@@ -9779,8 +9777,9 @@ gfc_match_structure_decl (void)
 	 and setting gfc_new_symbol, which is immediately used by
 	 parse_structure () and variable_decl () to add components of
 	 this type.  */
-      snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
+      name = gfc_get_string ("SS$%u", gfc_structure_id++);
     }
+  /* FIXME: should move gfc_is_intrinsic_typename to else branch here! */
 
   where = gfc_current_locus;
   /* No field list allowed after non-nested structure declaration.  */
@@ -9912,8 +9911,8 @@ typeis:
 match
 gfc_match_derived_decl (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
-  char parent[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
+  const char *parent = NULL;
   symbol_attribute attr;
   gfc_symbol *sym, *gensym;
   gfc_symbol *extended;
@@ -9927,14 +9926,12 @@ gfc_match_derived_decl (void)
   if (gfc_comp_struct (gfc_current_state ()))
     return MATCH_NO;
 
-  name[0] = '\0';
-  parent[0] = '\0';
   gfc_clear_attr (&attr);
   extended = NULL;
 
   do
     {
-      is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
+      is_type_attr_spec = gfc_get_type_attr_spec (&attr, &parent);
       if (is_type_attr_spec == MATCH_ERROR)
 	return MATCH_ERROR;
       if (is_type_attr_spec == MATCH_YES)
@@ -9944,10 +9941,10 @@ gfc_match_derived_decl (void)
   /* Deal with derived type extensions.  The extension attribute has
      been added to 'attr' but now the parent type must be found and
      checked.  */
-  if (parent[0])
+  if (parent != NULL)
     extended = check_extended_derived_type (parent);
 
-  if (parent[0] && !extended)
+  if (parent != NULL && !extended)
     return MATCH_ERROR;
 
   m = gfc_match (" ::");
@@ -9961,7 +9958,7 @@ gfc_match_derived_decl (void)
       return MATCH_ERROR;
     }
 
-  m = gfc_match (" %n ", name);
+  m = gfc_match (" %n ", &name);
   if (m != MATCH_YES)
     return m;
 
@@ -10474,7 +10471,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 	    goto error;
 	  if (m == MATCH_YES)
 	    {
-	      char arg[GFC_MAX_SYMBOL_LEN + 1];
+	      const char *arg = NULL;
 
 	      if (found_passing)
 		{
@@ -10483,11 +10480,11 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 		  goto error;
 		}
 
-	      m = gfc_match (" ( %n )", arg);
+	      m = gfc_match (" ( %n )", &arg);
 	      if (m == MATCH_ERROR)
 		goto error;
 	      if (m == MATCH_YES)
-		ba->pass_arg = gfc_get_string ("%s", arg);
+		ba->pass_arg = arg;
 	      gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
 
 	      found_passing = true;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6a5fe928b93..19a0eb28edd 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -120,7 +120,7 @@ fold_unary_intrinsic (gfc_intrinsic_op op)
    beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op.  */
 
 static gfc_intrinsic_op
-dtio_op (char* mode)
+dtio_op (const char* mode)
 {
   if (strncmp (mode, "formatted", 9) == 0)
     return INTRINSIC_FORMATTED;
@@ -139,7 +139,6 @@ gfc_match_generic_spec (interface_type *type,
 			const char *&name,
 			gfc_intrinsic_op *op)
 {
-  char buffer[GFC_MAX_SYMBOL_LEN + 1];
   match m;
   gfc_intrinsic_op i;
 
@@ -178,9 +177,9 @@ gfc_match_generic_spec (interface_type *type,
       return MATCH_YES;
     }
 
-  if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+  if (gfc_match (" read ( %n )", &name) == MATCH_YES)
     {
-      *op = dtio_op (buffer);
+      *op = dtio_op (name);
       if (*op == INTRINSIC_FORMATTED)
 	{
 	  name = gfc_code2string (dtio_procs, DTIO_RF);
@@ -195,9 +194,9 @@ gfc_match_generic_spec (interface_type *type,
 	return MATCH_YES;
     }
 
-  if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+  if (gfc_match (" write ( %n )", &name) == MATCH_YES)
     {
-      *op = dtio_op (buffer);
+      *op = dtio_op (name);
       if (*op == INTRINSIC_FORMATTED)
 	{
 	  name = gfc_code2string (dtio_procs, DTIO_WF);
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 1d07076c377..ab7e0f7bd04 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -3077,7 +3077,7 @@ check_namelist (gfc_symbol *sym)
 static match
 match_dt_element (io_kind k, gfc_dt *dt)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
 
@@ -3095,7 +3095,7 @@ match_dt_element (io_kind k, gfc_dt *dt)
 	return m;
     }
 
-  if (gfc_match (" nml = %n", name) == MATCH_YES)
+  if (gfc_match (" nml = %n", &name) == MATCH_YES)
     {
       if (dt->namelist != NULL)
 	{
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f3ad91a07c0..1b03e7251a5 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -606,12 +606,12 @@ cleanup:
 match
 gfc_match_label (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   match m;
 
   gfc_new_block = NULL;
 
-  m = gfc_match (" %n :", name);
+  m = gfc_match (" %n :", &name);
   if (m != MATCH_YES)
     return m;
 
@@ -991,7 +991,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result)
 match
 gfc_match_iterator (gfc_iterator *iter, int init_flag)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_expr *var, *e1, *e2, *e3;
   locus start;
   match m;
@@ -1001,7 +1001,7 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
   /* Match the start of an iterator without affecting the symbol table.  */
 
   start = gfc_current_locus;
-  m = gfc_match (" %n =", name);
+  m = gfc_match (" %n =", &name);
   gfc_current_locus = start;
 
   if (m != MATCH_YES)
@@ -1110,7 +1110,7 @@ gfc_match_char (char c)
    %%  Literal percent sign
    %e  Expression, pointer to a pointer is set
    %s  Symbol, pointer to the symbol is set
-   %n  Name, character buffer is set to name
+   %n  Name, pointer to pointer is set
    %t  Matches end of statement.
    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
    %l  Matches a statement label
@@ -1124,8 +1124,7 @@ gfc_match (const char *target, ...)
   int matches, *ip;
   locus old_loc;
   va_list argp;
-  char c, *np;
-  const char *name2_hack = NULL;
+  char c;
   match m, n;
   void **vp;
   const char *p;
@@ -1188,14 +1187,13 @@ loop:
 	  goto loop;
 
 	case 'n':
-	  np = va_arg (argp, char *);
-	  n = gfc_match_name (&name2_hack);
+	  vp = va_arg (argp, void **);
+	  n = gfc_match_name ((const char **) vp);
 	  if (n != MATCH_YES)
 	    {
 	      m = n;
 	      goto not_yes;
 	    }
-	  strcpy (np, name2_hack);
 
 	  matches++;
 	  goto loop;
@@ -1893,7 +1891,8 @@ gfc_match_associate (void)
       gfc_association_list* a;
 
       /* Match the next association.  */
-      if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
+      const char *name_hack = NULL;
+      if (gfc_match (" %n =>", &name_hack) != MATCH_YES)
 	{
 	  gfc_error ("Expected association at %C");
 	  goto assocListError;
@@ -1910,6 +1909,7 @@ gfc_match_associate (void)
 	    }
 	  gfc_matching_procptr_assignment = 0;
 	}
+      strcpy (newAssoc->name, name_hack);
       newAssoc->where = gfc_current_locus;
 
       /* Check that the current name is not yet in the list.  */
@@ -1978,7 +1978,7 @@ error:
 static match
 match_derived_type_spec (gfc_typespec *ts)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   locus old_locus;
   gfc_symbol *derived, *der_type;
   match m = MATCH_YES;
@@ -1987,7 +1987,7 @@ match_derived_type_spec (gfc_typespec *ts)
 
   old_locus = gfc_current_locus;
 
-  if (gfc_match ("%n", name) != MATCH_YES)
+  if (gfc_match ("%n", &name) != MATCH_YES)
     {
        gfc_current_locus = old_locus;
        return MATCH_NO;
@@ -2064,7 +2064,8 @@ gfc_match_type_spec (gfc_typespec *ts)
 {
   match m;
   locus old_locus;
-  char c, name[GFC_MAX_SYMBOL_LEN + 1];
+  char c;
+  const char *name = NULL;
 
   gfc_clear_ts (ts);
   gfc_gobble_whitespace ();
@@ -2131,7 +2132,7 @@ gfc_match_type_spec (gfc_typespec *ts)
      written the use of LOGICAL as a type-spec or intrinsic subprogram
      was overlooked.  */
 
-  m = gfc_match (" %n", name);
+  m = gfc_match (" %n", &name);
   if (m == MATCH_YES
       && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
     {
@@ -2173,7 +2174,7 @@ gfc_match_type_spec (gfc_typespec *ts)
 
       /* Look for the optional KIND=. */
       where = gfc_current_locus;
-      m = gfc_match ("%n", name);
+      m = gfc_match ("%n", &name); /* ??? maybe don't hash into identifier ?*/
       if (m == MATCH_YES)
 	{
 	  gfc_gobble_whitespace ();
@@ -2710,10 +2711,10 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
     sym = NULL;
   else
     {
-      char name[GFC_MAX_SYMBOL_LEN + 1];
+      const char *name = NULL;
       gfc_symtree* stree;
 
-      m = gfc_match ("% %n%t", name);
+      m = gfc_match ("% %n%t", &name);
       if (m == MATCH_ERROR)
 	return MATCH_ERROR;
       if (m == MATCH_NO)
@@ -4130,9 +4131,9 @@ gfc_match_allocate (void)
     goto cleanup;
   else if (m == MATCH_NO)
     {
-      char name[GFC_MAX_SYMBOL_LEN + 3];
+      const char *name = NULL;
 
-      if (gfc_match ("%n :: ", name) == MATCH_YES)
+      if (gfc_match ("%n :: ", &name) == MATCH_YES)
 	{
 	  gfc_error ("Error in type-spec at %L", &old_locus);
 	  goto cleanup;
@@ -4856,7 +4857,7 @@ match_typebound_call (gfc_symtree* varst)
 match
 gfc_match_call (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_actual_arglist *a, *arglist;
   gfc_case *new_case;
   gfc_symbol *sym;
@@ -4867,7 +4868,7 @@ gfc_match_call (void)
 
   arglist = NULL;
 
-  m = gfc_match ("% %n", name);
+  m = gfc_match ("% %n", &name);
   if (m == MATCH_NO)
     goto syntax;
   if (m != MATCH_YES)
@@ -4937,10 +4938,9 @@ gfc_match_call (void)
     {
       gfc_symtree *select_st;
       gfc_symbol *select_sym;
-      char name[GFC_MAX_SYMBOL_LEN + 1];
 
       new_st.next = c = gfc_get_code (EXEC_SELECT);
-      sprintf (name, "_result_%s", sym->name);
+      name = gfc_get_string ("_result_%s", sym->name);
       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
 
       select_sym = select_st->n.sym;
@@ -5263,7 +5263,7 @@ cleanup:
 match
 gfc_match_block_data (void)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
 
@@ -5277,7 +5277,7 @@ gfc_match_block_data (void)
       return MATCH_YES;
     }
 
-  m = gfc_match ("% %n%t", name);
+  m = gfc_match ("% %n%t", &name);
   if (m != MATCH_YES)
     return MATCH_ERROR;
 
@@ -6095,7 +6095,7 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
 static void
 select_type_set_tmp (gfc_typespec *ts)
 {
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name = NULL;
   gfc_symtree *tmp = NULL;
 
   if (!ts)
@@ -6112,9 +6112,9 @@ select_type_set_tmp (gfc_typespec *ts)
 	return;
 
       if (ts->type == BT_CLASS)
-	sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+	name = gfc_get_string ("__tmp_class_%s", ts->u.derived->name);
       else
-	sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+	name = gfc_get_string ("__tmp_type_%s", ts->u.derived->name);
       gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
       gfc_add_type (tmp->n.sym, ts, NULL);
 
@@ -6163,7 +6163,7 @@ gfc_match_select_type (void)
 {
   gfc_expr *expr1, *expr2 = NULL;
   match m;
-  char name[GFC_MAX_SYMBOL_LEN];
+  const char *name = NULL;
   bool class_array;
   gfc_symbol *sym;
   gfc_namespace *ns = gfc_current_ns;
@@ -6177,7 +6177,7 @@ gfc_match_select_type (void)
     return m;
 
   gfc_current_ns = gfc_build_block_ns (ns);
-  m = gfc_match (" %n => %e", name, &expr2);
+  m = gfc_match (" %n => %e", &name, &expr2);
   if (m == MATCH_YES)
     {
       expr1 = gfc_get_expr ();
diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c
index bb01af9f636..6e82f5c3ca5 100644
--- a/gcc/fortran/matchexp.c
+++ b/gcc/fortran/matchexp.c
@@ -44,14 +44,14 @@ gfc_match_defined_op_name (const char *&result, int error_flag,
       NULL
   };
 
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   locus old_loc;
   match m;
   int i;
 
   old_loc = gfc_current_locus;
 
-  m = gfc_match (" . %n .", name);
+  m = gfc_match (" . %n .", &name);
   if (m != MATCH_YES)
     return m;
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1064f3c80cb..8628f3aeda9 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -519,7 +519,7 @@ free_rename (gfc_use_rename *list)
 match
 gfc_match_use (void)
 {
-  char module_nature[GFC_MAX_SYMBOL_LEN + 1];
+  const char *module_nature = NULL;
   const char *name = NULL;
   gfc_use_rename *tail = NULL, *new_use;
   interface_type type, type2;
@@ -531,7 +531,7 @@ gfc_match_use (void)
 
   if (gfc_match (" , ") == MATCH_YES)
     {
-      if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
+      if ((m = gfc_match (" %n ::", &module_nature)) == MATCH_YES)
 	{
 	  if (!gfc_notify_std (GFC_STD_F2003, "module "
 			       "nature in USE statement at %C"))
@@ -555,7 +555,7 @@ gfc_match_use (void)
 	{
 	  /* Help output a better error message than "Unclassifiable
 	     statement".  */
-	  gfc_match (" %n", module_nature);
+	  gfc_match (" %n", &module_nature);
 	  if (strcmp (module_nature, "intrinsic") == 0
 	      || strcmp (module_nature, "non_intrinsic") == 0)
 	    gfc_error ("\"::\" was expected after module nature at %C "
@@ -738,7 +738,7 @@ match
 gfc_match_submodule (void)
 {
   match m;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   gfc_use_list *use_list;
   bool seen_colon = false;
 
@@ -760,7 +760,7 @@ gfc_match_submodule (void)
 
   while (1)
     {
-      m = gfc_match (" %n", name);
+      m = gfc_match (" %n", &name);
       if (m != MATCH_YES)
 	goto syntax;
 
@@ -781,7 +781,7 @@ gfc_match_submodule (void)
       else
 	{
 	  module_list = use_list;
-	  use_list->module_name = gfc_get_string ("%s", name);
+	  use_list->module_name = name;
 	  use_list->submodule_name = use_list->module_name;
 	}
 
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 10a5df92e61..08bc05cbc28 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -94,7 +94,6 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
     gfc_free_omp_namelist (c->lists[i]);
   gfc_free_expr_list (c->wait_list);
   gfc_free_expr_list (c->tile_list);
-  free (CONST_CAST (char *, c->critical_name));
   free (c);
 }
 
@@ -226,7 +225,7 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
 {
   gfc_omp_namelist *head, *tail, *p;
   locus old_loc, cur_loc;
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   gfc_symtree *st;
@@ -284,16 +283,16 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
       if (!allow_common)
 	goto syntax;
 
-      m = gfc_match (" / %n /", n);
+      m = gfc_match (" / %n /", &name);
       if (m == MATCH_ERROR)
 	goto cleanup;
       if (m == MATCH_NO)
 	goto syntax;
 
-      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
       if (st == NULL)
 	{
-	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  gfc_error ("COMMON block /%s/ not found at %C", name);
 	  goto cleanup;
 	}
       for (sym = st->n.common->head; sym; sym = sym->common_next)
@@ -348,7 +347,7 @@ gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
 {
   gfc_omp_namelist *head, *tail, *p;
   locus old_loc, cur_loc;
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   gfc_symtree *st;
@@ -385,16 +384,16 @@ gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
 	  goto cleanup;
 	}
 
-      m = gfc_match (" / %n /", n);
+      m = gfc_match (" / %n /", &name);
       if (m == MATCH_ERROR)
 	goto cleanup;
       if (m == MATCH_NO)
 	goto syntax;
 
-      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
       if (st == NULL)
 	{
-	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  gfc_error ("COMMON block /%s/ not found at %C", name);
 	  goto cleanup;
 	}
       p = gfc_get_omp_namelist ();
@@ -636,7 +635,7 @@ gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
   gfc_omp_namelist *head = NULL;
   gfc_omp_namelist *tail, *p;
   locus old_loc;
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   gfc_symtree *st;
@@ -680,16 +679,16 @@ gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
 	  goto cleanup;
 	}
 
-      m = gfc_match (" / %n /", n);
+      m = gfc_match (" / %n /", &name);
       if (m == MATCH_ERROR)
 	goto cleanup;
-      if (m == MATCH_NO || n[0] == '\0')
+      if (m == MATCH_NO)
 	goto syntax;
 
-      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
       if (st == NULL)
 	{
-	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  gfc_error ("COMMON block /%s/ not found at %C", name);
 	  goto cleanup;
 	}
 
@@ -2451,12 +2450,11 @@ match_omp (gfc_exec_op op, const omp_mask mask)
 match
 gfc_match_omp_critical (void)
 {
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_omp_clauses *c = NULL;
 
-  if (gfc_match (" ( %n )", n) != MATCH_YES)
+  if (gfc_match (" ( %n )", &name) != MATCH_YES)
     {
-      n[0] = '\0';
       if (gfc_match_omp_eos () != MATCH_YES)
 	{
 	  gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
@@ -2468,8 +2466,8 @@ gfc_match_omp_critical (void)
 
   new_st.op = EXEC_OMP_CRITICAL;
   new_st.ext.omp_clauses = c;
-  if (n[0])
-    c->critical_name = xstrdup (n);
+  if (name != NULL)
+    c->critical_name = name;
   return MATCH_YES;
 }
 
@@ -2477,10 +2475,9 @@ gfc_match_omp_critical (void)
 match
 gfc_match_omp_end_critical (void)
 {
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
 
-  if (gfc_match (" ( %n )", n) != MATCH_YES)
-    n[0] = '\0';
+  gfc_match (" ( %n )", &name);
   if (gfc_match_omp_eos () != MATCH_YES)
     {
       gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
@@ -2488,7 +2485,7 @@ gfc_match_omp_end_critical (void)
     }
 
   new_st.op = EXEC_OMP_END_CRITICAL;
-  new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+  new_st.ext.omp_name = name;
   return MATCH_YES;
 }
 
@@ -2601,7 +2598,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
 {
   match m;
   locus old_loc = gfc_current_locus;
-  char sname[GFC_MAX_SYMBOL_LEN + 1];
+  const char *sname = NULL;
   gfc_symbol *sym;
   gfc_namespace *ns = gfc_current_ns;
   gfc_expr *lvalue = NULL, *rvalue = NULL;
@@ -2627,7 +2624,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
       gfc_free_expr (lvalue);
     }
 
-  m = gfc_match (" %n", sname);
+  m = gfc_match (" %n", &sname);
   if (m != MATCH_YES)
     return false;
 
@@ -2799,8 +2796,7 @@ gfc_match_omp_declare_reduction (void)
 {
   match m;
   gfc_intrinsic_op op;
-  char name[GFC_MAX_SYMBOL_LEN + 3];
-  const char *oper = NULL;
+  const char *name = NULL;
   auto_vec<gfc_typespec, 5> tss;
   gfc_typespec ts;
   unsigned int i;
@@ -2818,24 +2814,22 @@ gfc_match_omp_declare_reduction (void)
     return MATCH_ERROR;
   if (m == MATCH_YES)
     {
-      oper = gfc_get_string ("operator %s", gfc_op2string (op));
-      strcpy (name, oper);
+      name = gfc_get_string ("operator %s", gfc_op2string (op));
       rop = (gfc_omp_reduction_op) op;
     }
   else
     {
-      m = gfc_match_defined_op_name (oper, 1, 1);
+      m = gfc_match_defined_op_name (name, 1, 1);
       if (m == MATCH_ERROR)
 	return MATCH_ERROR;
       if (m == MATCH_YES)
 	{
 	  if (gfc_match (" : ") != MATCH_YES)
 	    return MATCH_ERROR;
-	  strcpy (name, oper);
 	}
       else
 	{
-	  if (gfc_match (" %n : ", name) != MATCH_YES)
+	  if (gfc_match (" %n : ", &name) != MATCH_YES)
 	    return MATCH_ERROR;
 	}
       rop = OMP_REDUCTION_USER;
@@ -2869,7 +2863,7 @@ gfc_match_omp_declare_reduction (void)
       const char *predef_name = NULL;
 
       omp_udr = gfc_get_omp_udr ();
-      omp_udr->name = gfc_get_string ("%s", name);
+      omp_udr->name = name;
       omp_udr->rop = rop;
       omp_udr->ts = tss[i];
       omp_udr->where = where;
@@ -3132,7 +3126,7 @@ match
 gfc_match_omp_threadprivate (void)
 {
   locus old_loc;
-  char n[GFC_MAX_SYMBOL_LEN+1];
+  const char *name = NULL;
   gfc_symbol *sym;
   match m;
   gfc_symtree *st;
@@ -3161,16 +3155,16 @@ gfc_match_omp_threadprivate (void)
 	  goto cleanup;
 	}
 
-      m = gfc_match (" / %n /", n);
+      m = gfc_match (" / %n /", &name);
       if (m == MATCH_ERROR)
 	goto cleanup;
-      if (m == MATCH_NO || n[0] == '\0')
+      if (m == MATCH_NO)
 	goto syntax;
 
-      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
       if (st == NULL)
 	{
-	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  gfc_error ("COMMON block /%s/ not found at %C", name);
 	  goto cleanup;
 	}
       st->n.common->threadprivate = 1;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 13cc6f5fccd..880671b57f4 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3590,7 +3590,7 @@ match_deferred_characteristics (gfc_typespec * ts)
 {
   locus loc;
   match m = MATCH_ERROR;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
 
   loc = gfc_current_locus;
 
@@ -3616,7 +3616,7 @@ match_deferred_characteristics (gfc_typespec * ts)
   /* Set the function locus correctly.  If we have not found the
      function name, there is an error.  */
   if (m == MATCH_YES
-      && gfc_match ("function% %n", name) == MATCH_YES
+      && gfc_match ("function% %n", &name) == MATCH_YES
       && strcmp (name, gfc_current_block ()->name) == 0)
     {
       gfc_current_block ()->declared_at = gfc_current_locus;
@@ -5228,7 +5228,6 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 			 new_st.ext.omp_name) != 0))
 	gfc_error ("Name after !$omp critical and !$omp end critical does "
 		   "not match at %C");
-      free (CONST_CAST (char *, new_st.ext.omp_name));
       new_st.ext.omp_name = NULL;
       break;
     case EXEC_OMP_END_SINGLE:
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index b30938ef61c..da661372c5c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1692,7 +1692,7 @@ cleanup:
 static match
 match_arg_list_function (gfc_actual_arglist *result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name = NULL;
   locus old_locus;
   match m;
 
@@ -1704,7 +1704,7 @@ match_arg_list_function (gfc_actual_arglist *result)
       goto cleanup;
     }
 
-  m = gfc_match ("%n (", name);
+  m = gfc_match ("%n (", &name);
   if (m != MATCH_YES)
     goto cleanup;
 
@@ -3144,7 +3144,7 @@ match
 gfc_match_rvalue (gfc_expr **result)
 {
   gfc_actual_arglist *actual_arglist;
-  char argname[GFC_MAX_SYMBOL_LEN + 1];
+  const char *argname = NULL;
   const char *name = NULL;
   gfc_state_data *st;
   gfc_symbol *sym;
@@ -3526,7 +3526,7 @@ gfc_match_rvalue (gfc_expr **result)
 	 symbol would end up in the symbol table.  */
 
       old_loc = gfc_current_locus;
-      m2 = gfc_match (" ( %n =", argname);
+      m2 = gfc_match (" ( %n =", &argname);
       gfc_current_locus = old_loc;
 
       e = gfc_get_expr ();
-- 
2.19.0.rc1

[PATCH,FORTRAN 24/29] Use stringpool for intrinsic functions

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* iresolve.c (gfc_resolve_ctime_sub): Use stringpool for
	intrinsic subroutine name.
	(gfc_resolve_fdate_sub): Likewise.
	(gfc_resolve_gerror): Likewise.
	(gfc_resolve_getlog): Likewise.
	(gfc_resolve_perror): Likewise.
	(gfc_resolve_fseek_sub): Likewise.
	(gfc_resolve_ttynam_sub): Likewise.
---
 gcc/fortran/iresolve.c | 24 ++++++++++++++++--------
 1 file changed, 16 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index f22e0da54c9..61663fec7e5 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -3787,6 +3787,7 @@ gfc_resolve_flush (gfc_code *c)
 void
 gfc_resolve_ctime_sub (gfc_code *c)
 {
+  const char *name;
   gfc_typespec ts;
   gfc_clear_ts (&ts);
 
@@ -3800,28 +3801,32 @@ gfc_resolve_ctime_sub (gfc_code *c)
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
+  name = gfc_get_string (PREFIX ("ctime_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 
 void
 gfc_resolve_fdate_sub (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
+  const char *name = gfc_get_string (PREFIX ("fdate_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 
 void
 gfc_resolve_gerror (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
+  const char *name = gfc_get_string (PREFIX ("gerror"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 
 void
 gfc_resolve_getlog (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
+  const char *name = gfc_get_string (PREFIX ("getlog"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 
@@ -3844,7 +3849,8 @@ gfc_resolve_hostnm_sub (gfc_code *c)
 void
 gfc_resolve_perror (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
+  const char *name = gfc_get_string (PREFIX ("perror_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
@@ -3976,6 +3982,7 @@ gfc_resolve_fput_sub (gfc_code *c)
 void
 gfc_resolve_fseek_sub (gfc_code *c)
 {
+  const char *name;
   gfc_expr *unit;
   gfc_expr *offset;
   gfc_expr *whence;
@@ -4012,8 +4019,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
       ts.u.cl = NULL;
       gfc_convert_type (whence, &ts, 2);
     }
-
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+  name = gfc_get_string (PREFIX ("fseek_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 void
@@ -4045,6 +4052,7 @@ gfc_resolve_ftell_sub (gfc_code *c)
 void
 gfc_resolve_ttynam_sub (gfc_code *c)
 {
+  const char *name = gfc_get_string (PREFIX ("ttynam_sub"));
   gfc_typespec ts;
   gfc_clear_ts (&ts);
 
@@ -4057,7 +4065,7 @@ gfc_resolve_ttynam_sub (gfc_code *c)
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 14/29] Fix write_omp_udr for user-operator REDUCTIONs

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Due to a typo a user operator used in a reduction was not found in the
symtree so would have been written multiple times (in theory).

E.g. user operator ".add." was looked up as ".ad" instead of "add".

For gcc-8 branch and earlier one would
-         memcpy (name, udr->name, len - 1);
+         memcpy (name, udr->name + 1, len - 1);

but for gcc-9 we have an appropriate helper already.
Jakub, please take care of non-trunk branches if you want it fixed
there.

gcc/fortran/ChangeLog:

2017-11-16  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* module.c (write_omp_udr): Use gfc_get_name_from_uop.
---
 gcc/fortran/module.c | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index fe5ae34dd13..b94411ac68b 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -5685,12 +5685,8 @@ write_omp_udr (gfc_omp_udr *udr)
 	return;
       else
 	{
-	  gfc_symtree *st;
-	  size_t len = strlen (udr->name + 1);
-	  char *name = XALLOCAVEC (char, len);
-	  memcpy (name, udr->name, len - 1);
-	  name[len - 1] = '\0';
-	  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+	  const char *name = gfc_get_name_from_uop (udr->name);
+	  gfc_symtree *st = gfc_find_symtree (gfc_current_ns->uop_root, name);
 	  /* If corresponding user operator is private, don't write
 	     the UDR.  */
 	  if (st != NULL)
-- 
2.19.0.rc1

[PATCH,FORTRAN 22/29] Use stringpool in class and procedure-pointer result

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-26  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* class.c (finalize_component): Use stringpool.
	(finalization_scalarizer): Likewise.
	* frontend-passes.c (create_var): Likewise.
	(get_len_trim_call): Likewise.
	* iresolve.c (gfc_resolve_atomic_def): Likewise.
	(gfc_resolve_atomic_ref): Likewise.
	(gfc_resolve_event_query): Likewise.
	* openmp.c (gfc_match_omp_declare_reduction): Likewise.
	* parse.c (gfc_parse_file): Likewise.
	* resolve.c (build_loc_call): Likewise.
	(resolve_ordinary_assign): Likewise.
	* decl.c (add_hidden_procptr_result): Likewise and use pointer
	comparison instead of string comparison.
---
 gcc/fortran/class.c           | 10 +++++++---
 gcc/fortran/decl.c            | 11 +++++++----
 gcc/fortran/frontend-passes.c | 10 ++++++----
 gcc/fortran/iresolve.c        |  6 +++---
 gcc/fortran/openmp.c          | 13 +++++++++----
 gcc/fortran/parse.c           |  2 +-
 gcc/fortran/resolve.c         |  6 ++++--
 7 files changed, 37 insertions(+), 21 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 20a68da8e9b..33c772c6eba 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -959,12 +959,13 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
       dealloc->ext.alloc.list->expr = e;
       dealloc->expr1 = gfc_lval_expr_from_sym (stat);
 
+      const char *sname = gfc_get_string ("%s", "associated");
       gfc_code *cond = gfc_get_code (EXEC_IF);
       cond->block = gfc_get_code (EXEC_IF);
       cond->block->expr1 = gfc_get_expr ();
       cond->block->expr1->expr_type = EXPR_FUNCTION;
       cond->block->expr1->where = gfc_current_locus;
-      gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
+      gfc_get_sym_tree (sname, sub_ns, &cond->block->expr1->symtree, false);
       cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
       cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
       cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
@@ -1038,10 +1039,12 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
 {
   gfc_code *block;
   gfc_expr *expr, *expr2;
+  const char *sname;
 
   /* C_F_POINTER().  */
   block = gfc_get_code (EXEC_CALL);
-  gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+  sname = gfc_get_string ("%s", "c_f_pointer");
+  gfc_get_sym_tree (sname, sub_ns, &block->symtree, true);
   block->resolved_sym = block->symtree->n.sym;
   block->resolved_sym->attr.flavor = FL_PROCEDURE;
   block->resolved_sym->attr.intrinsic = 1;
@@ -1063,7 +1066,8 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   /* TRANSFER's first argument: C_LOC (array).  */
   expr = gfc_get_expr ();
   expr->expr_type = EXPR_FUNCTION;
-  gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+  sname = gfc_get_string ("%s", "c_loc");
+  gfc_get_sym_tree (sname, sub_ns, &expr->symtree, false);
   expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
   expr->symtree->n.sym->attr.intrinsic = 1;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index cc14a871dfd..1f148c88eb8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -6441,6 +6441,7 @@ static bool
 add_hidden_procptr_result (gfc_symbol *sym)
 {
   bool case1,case2;
+  const char *ppr_name;
 
   if (gfc_notification_std (GFC_STD_F2003) == ERROR)
     return false;
@@ -6454,16 +6455,18 @@ add_hidden_procptr_result (gfc_symbol *sym)
 	  && gfc_state_stack->previous->state == COMP_FUNCTION
 	  && gfc_state_stack->previous->sym->name == sym->name;
 
+  ppr_name = gfc_get_string ("%s", "ppr@");
   if (case1 || case2)
     {
+
       gfc_symtree *stree;
       if (case1)
-	gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
+	gfc_get_sym_tree (ppr_name, gfc_current_ns, &stree, false);
       else if (case2)
 	{
 	  gfc_symtree *st2;
-	  gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
-	  st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+	  gfc_get_sym_tree (ppr_name, gfc_current_ns->parent, &stree, false);
+	  st2 = gfc_new_symtree (&gfc_current_ns->sym_root, ppr_name);
 	  st2->n.sym = stree->n.sym;
 	  stree->n.sym->refs++;
 	}
@@ -6490,7 +6493,7 @@ add_hidden_procptr_result (gfc_symbol *sym)
 	   && sym->result && sym->result != sym && sym->result->attr.external
 	   && sym == gfc_current_ns->proc_name
 	   && sym == sym->result->ns->proc_name
-	   && strcmp ("ppr@", sym->result->name) == 0)
+	   && sym->result->name == ppr_name)
     {
       sym->result->attr.proc_pointer = 1;
       sym->attr.pointer = 0;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index d549d8b6ffd..ccbc25acf97 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -713,7 +713,7 @@ insert_block ()
 static gfc_expr*
 create_var (gfc_expr * e, const char *vname)
 {
-  char name[GFC_MAX_SYMBOL_LEN +1];
+  const char *name;
   gfc_symtree *symtree;
   gfc_symbol *symbol;
   gfc_expr *result;
@@ -733,9 +733,9 @@ create_var (gfc_expr * e, const char *vname)
   ns = insert_block ();
 
   if (vname)
-    snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
+    name = gfc_get_string ("__var_%d_%s", var_num++, vname);
   else
-    snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
+    name = gfc_get_string ("__var_%d", var_num++);
 
   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
     gcc_unreachable ();
@@ -1985,6 +1985,7 @@ get_len_trim_call (gfc_expr *str, int kind)
 {
   gfc_expr *fcn;
   gfc_actual_arglist *actual_arglist, *next;
+  const char *sname;
 
   fcn = gfc_get_expr ();
   fcn->expr_type = EXPR_FUNCTION;
@@ -2000,7 +2001,8 @@ get_len_trim_call (gfc_expr *str, int kind)
   fcn->ts.type = BT_INTEGER;
   fcn->ts.kind = gfc_charlen_int_kind;
 
-  gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+  sname = gfc_get_string ("%s", "__internal_len_trim");
+  gfc_get_sym_tree (sname, current_ns, &fcn->symtree, false);
   fcn->symtree->n.sym->ts = fcn->ts;
   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   fcn->symtree->n.sym->attr.function = 1;
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 2eb8f7c9113..f22e0da54c9 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -3351,7 +3351,7 @@ create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
 void
 gfc_resolve_atomic_def (gfc_code *c)
 {
-  const char *name = "atomic_define";
+  const char *name = gfc_get_string ("%s", "atomic_define");
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
@@ -3359,14 +3359,14 @@ gfc_resolve_atomic_def (gfc_code *c)
 void
 gfc_resolve_atomic_ref (gfc_code *c)
 {
-  const char *name = "atomic_ref";
+  const char *name = gfc_get_string ("%s", "atomic_ref");
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
 void
 gfc_resolve_event_query (gfc_code *c)
 {
-  const char *name = "event_query";
+  const char *name = gfc_get_string ("%s", "event_query");
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index a868e34193f..fcfe671be8b 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2860,6 +2860,7 @@ gfc_match_omp_declare_reduction (void)
       gfc_namespace *combiner_ns, *initializer_ns = NULL;
       gfc_omp_udr *prev_udr, *omp_udr;
       const char *predef_name = NULL;
+      const char *sname;
 
       omp_udr = gfc_get_omp_udr ();
       omp_udr->name = name;
@@ -2870,8 +2871,10 @@ gfc_match_omp_declare_reduction (void)
       gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
       combiner_ns->proc_name = combiner_ns->parent->proc_name;
 
-      gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
-      gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
+      sname = gfc_get_string ("%s", "omp_out");
+      gfc_get_sym_tree (sname, combiner_ns, &omp_out, false);
+      sname = gfc_get_string ("%s", "omp_in");
+      gfc_get_sym_tree (sname, combiner_ns, &omp_in, false);
       combiner_ns->omp_udr_ns = 1;
       omp_out->n.sym->ts = tss[i];
       omp_in->n.sym->ts = tss[i];
@@ -2903,8 +2906,10 @@ gfc_match_omp_declare_reduction (void)
 	  gfc_current_ns = initializer_ns;
 	  initializer_ns->proc_name = initializer_ns->parent->proc_name;
 
-	  gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
-	  gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
+	  sname = gfc_get_string ("%s", "omp_priv");
+	  gfc_get_sym_tree (sname, initializer_ns, &omp_priv, false);
+	  sname = gfc_get_string ("%s", "omp_orig");
+	  gfc_get_sym_tree (sname, initializer_ns, &omp_orig, false);
 	  initializer_ns->omp_udr_ns = 1;
 	  omp_priv->n.sym->ts = tss[i];
 	  omp_orig->n.sym->ts = tss[i];
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 755bff56e24..b7265c42f58 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -6252,7 +6252,7 @@ loop:
       prog_locus = gfc_current_locus;
 
       push_state (&s, COMP_PROGRAM, gfc_new_block);
-      main_program_symbol (gfc_current_ns, "MAIN__");
+      main_program_symbol (gfc_current_ns, gfc_get_string ("MAIN__"));
       parse_progunit (st);
       goto prog_units;
     }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 88c16d462bd..8072bd20435 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8814,10 +8814,11 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
 static gfc_expr *
 build_loc_call (gfc_expr *sym_expr)
 {
+  const char *loc = gfc_get_string ("%s", "_loc");
   gfc_expr *loc_call;
   loc_call = gfc_get_expr ();
   loc_call->expr_type = EXPR_FUNCTION;
-  gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
+  gfc_get_sym_tree (loc, gfc_current_ns, &loc_call->symtree, false);
   loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
   loc_call->symtree->n.sym->attr.intrinsic = 1;
   loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
@@ -10487,12 +10488,13 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
      path.  */
   if (caf_convert_to_send)
     {
+      const char *sname = gfc_get_string ("%s", GFC_PREFIX ("caf_send"));
       if (code->expr2->expr_type == EXPR_FUNCTION
 	  && code->expr2->value.function.isym
 	  && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
 	remove_caf_get_intrinsic (code->expr2);
       code->op = EXEC_CALL;
-      gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
+      gfc_get_sym_tree (sname, ns, &code->symtree, true);
       code->resolved_sym = code->symtree->n.sym;
       code->resolved_sym->attr.flavor = FL_PROCEDURE;
       code->resolved_sym->attr.intrinsic = 1;
-- 
2.19.0.rc1

[PATCH,FORTRAN 25/29] Use stringpool on loading module symbols

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* module.c (load_needed): Use stringpool when generating symbols
	and module names.
---
 gcc/fortran/module.c | 17 ++++++++++++-----
 1 file changed, 12 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8f6dc9f2864..ebfcd62801d 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -4857,6 +4857,7 @@ load_needed (pointer_info *p)
   pointer_info *q;
   gfc_symbol *sym;
   int rv;
+  const char *true_name, *module;
 
   rv = 0;
   if (p == NULL)
@@ -4888,15 +4889,21 @@ load_needed (pointer_info *p)
 	  associate_integer_pointer (q, ns);
 	}
 
+      true_name = p->u.rsym.true_name;
+      if (true_name[0] != '\0')
+	true_name = gfc_get_string ("%s", true_name);
+      module = p->u.rsym.module;
+      if (module[0] != '\0')
+	module = gfc_get_string ("%s", module);
+
       /* 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);
+	gfc_find_symbol (module, gfc_current_ns, 1, &ns->proc_name);
 
-      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);
+      sym = gfc_new_symbol (true_name, ns);
+      sym->name = gfc_dt_lower_string (true_name);
+      sym->module = module;
       if (p->u.rsym.binding_label)
 	sym->binding_label = p->u.rsym.binding_label;
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 11/29] Do pointer comparison instead of strcmp

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

This gets rid of some of the str[n]*cmp in favour of (faster) pointer
equality checks.

gcc/fortran/ChangeLog:

2017-11-02  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* check.c (gfc_check_move_alloc): Use pointer comparison instead
	of strcmp.
	* class.c (find_intrinsic_vtab): Likewise.
	* decl.c (find_special, check_function_name, variable_decl,
	insert_parameter_exprs, gfc_get_pdt_instance,
	gfc_match_formal_arglist, match_result, add_hidden_procptr_result,
	add_global_entry, gfc_match_end): Likewise.
	* interface.c (gfc_match_end_interface, compare_components,
	gfc_compare_derived_types, find_keyword_arg, count_types_test,
	generic_correspondence, compare_actual_formal,
	gfc_check_typebound_override): Likewise.
	* match.c (gfc_match_else, gfc_match_elseif, match_case_eos,
	gfc_match_elsewhere): Likewise.
	* openmp.c (gfc_match_oacc_routine, match_udr_expr,
	gfc_omp_udr_find): Likewise.
	* parse.c (match_deferred_characteristics,
	parse_omp_structured_block, add_global_procedure): Likewise.
	* resolve.c (check_proc_interface, resolve_formal_arglist,
	resolve_contained_fntype, resolve_common_blocks,
	count_specific_procs, not_entry_self_reference,
	resolve_global_procedure, resolve_select_type,
	gfc_verify_binding_labels, build_init_assign, compare_fsyms,
	resolve_typebound_procedure, resolve_component): Likewise.
	* symbol.c (gfc_add_component, gfc_find_component): Likewise.
	* trans-array.c (structure_alloc_comps): Likewise.
	* trans-decl.c (gfc_get_extern_function_decl, build_entry_thunks,
	gfc_get_fake_result_decl, struct module_hasher,
	module_decl_hasher::equal, gfc_trans_use_stmts,
	generate_local_decl): Likewise.
	* trans-expr.c (conv_parent_component_references,
	gfc_conv_procedure_call): Likewise.
	* module.c (mio_namelist, find_symbol, load_omp_udrs,
	read_module): Likewise.
---
 gcc/fortran/check.c       |  2 +-
 gcc/fortran/class.c       |  2 +-
 gcc/fortran/decl.c        | 31 +++++++++++++++---------------
 gcc/fortran/interface.c   | 34 ++++++++++++++++-----------------
 gcc/fortran/match.c       |  8 ++++----
 gcc/fortran/module.c      | 17 ++++++++---------
 gcc/fortran/openmp.c      |  7 +++----
 gcc/fortran/parse.c       | 10 ++++------
 gcc/fortran/resolve.c     | 40 +++++++++++++++++++--------------------
 gcc/fortran/symbol.c      |  6 +++---
 gcc/fortran/trans-array.c |  4 ++--
 gcc/fortran/trans-decl.c  | 24 +++++++++++------------
 gcc/fortran/trans-expr.c  |  7 +++----
 13 files changed, 91 insertions(+), 101 deletions(-)

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 30214fef4c7..cb18a3af519 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3566,7 +3566,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       of reflection reveals that this can only occur for derived types
       with recursive allocatable components.  */
   if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
-      && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+      && to->symtree->n.sym->name == from->symtree->n.sym->name)
     {
       gfc_ref *to_ref, *from_ref;
       to_ref = to->ref;
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2eae7f0f351..8e637689fae 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2736,7 +2736,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		  contained = ns->contained;
 		  for (; contained; contained = contained->sibling)
 		    if (contained->proc_name
-			&& strcmp (name, contained->proc_name->name) == 0)
+			&& name == contained->proc_name->name)
 		      {
 			copy = contained->proc_name;
 			goto got_char_copy;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b0c45b88505..2baa1783434 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1118,7 +1118,7 @@ find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
   if (s->sym == NULL)
     goto end;		  /* Nameless interface.  */
 
-  if (strcmp (name, s->sym->name) == 0)
+  if (name == s->sym->name)
     {
       *result = s->sym;
       return 0;
@@ -2273,7 +2273,7 @@ check_function_name (const char *name)
       gfc_symbol *block = gfc_current_block ();
       if (block && block->result && block->result != block
 	  && strcmp (block->result->name, "ppr@") != 0
-	  && strcmp (block->name, name) == 0)
+	  && block->name == name)
 	{
 	  gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
 		     "from appearing in a specification statement",
@@ -2583,11 +2583,11 @@ variable_decl (int elem)
   /* Procedure pointer as function result.  */
   if (gfc_current_state () == COMP_FUNCTION
       && strcmp ("ppr@", gfc_current_block ()->name) == 0
-      && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
+      && name == gfc_current_block ()->ns->proc_name->name)
     name = gfc_get_string ("%s", "ppr@");
 
   if (gfc_current_state () == COMP_FUNCTION
-      && strcmp (name, gfc_current_block ()->name) == 0
+      && name == gfc_current_block ()->name
       && gfc_current_block ()->result
       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
     name = gfc_get_string ("%s", "ppr@");
@@ -3359,7 +3359,7 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
       || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
     {
       for (param = type_param_spec_list; param; param = param->next)
-	if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+	if (e->symtree->n.sym->name == param->name)
 	  break;
 
       if (param)
@@ -3483,7 +3483,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	  actual_param = param_list;
 	  for (;actual_param; actual_param = actual_param->next)
 	    if (actual_param->name
-	        && strcmp (actual_param->name, param->name) == 0)
+	        && actual_param->name == param->name)
 	      break;
 	  if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
 	    kind_expr = gfc_copy_expr (actual_param->expr);
@@ -6215,7 +6215,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
 	 so check for it explicitly.  After the statement is accepted,
 	 the name is checked for especially in gfc_get_symbol().  */
       if (gfc_new_block != NULL && sym != NULL && !typeparam
-	  && strcmp (sym->name, gfc_new_block->name) == 0)
+	  && sym->name == gfc_new_block->name)
 	{
 	  gfc_error ("Name %qs at %C is the name of the procedure",
 		     sym->name);
@@ -6290,7 +6290,7 @@ ok:
 	      || (p->next == NULL && q->next != NULL))
 	    arg_count_mismatch = true;
 	  else if ((p->sym == NULL && q->sym == NULL)
-		    || strcmp (p->sym->name, q->sym->name) == 0)
+		    || p->sym->name == q->sym->name)
 	    continue;
 	  else
 	    gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
@@ -6336,7 +6336,7 @@ match_result (gfc_symbol *function, gfc_symbol **result)
       return MATCH_ERROR;
     }
 
-  if (strcmp (function->name, name) == 0)
+  if (function->name == name)
     {
       gfc_error ("RESULT variable at %C must be different than function name");
       return MATCH_ERROR;
@@ -6451,12 +6451,12 @@ add_hidden_procptr_result (gfc_symbol *sym)
 
   /* First usage case: PROCEDURE and EXTERNAL statements.  */
   case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
-	  && strcmp (gfc_current_block ()->name, sym->name) == 0
+	  && gfc_current_block ()->name == sym->name
 	  && sym->attr.external;
   /* Second usage case: INTERFACE statements.  */
   case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
 	  && gfc_state_stack->previous->state == COMP_FUNCTION
-	  && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
+	  && gfc_state_stack->previous->sym->name == sym->name;
 
   if (case1 || case2)
     {
@@ -7148,7 +7148,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,
   /* Don't add the symbol multiple times.  */
   if (binding_label
       && (!gfc_notification_std (GFC_STD_F2008)
-	  || strcmp (name, binding_label) != 0))
+	  || name != binding_label))
     {
       s = gfc_get_gsymbol (binding_label);
 
@@ -8044,9 +8044,8 @@ gfc_match_end (gfc_statement *st)
   /* 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)
+    block_name = gfc_get_string ("%s", strchr (block_name, '.') + 1);
+  if (name != block_name && strcmp (block_name, "ppr@") != 0)
     {
       gfc_error ("Expected label %qs for %s statement at %C", block_name,
 		 gfc_ascii_statement (*st));
@@ -8054,7 +8053,7 @@ gfc_match_end (gfc_statement *st)
     }
   /* Procedure pointer as function result.  */
   else if (strcmp (block_name, "ppr@") == 0
-	   && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+	   && name != gfc_current_block ()->ns->proc_name->name)
     {
       gfc_error ("Expected label %qs for %s statement at %C",
 		 gfc_current_block ()->ns->proc_name->name,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 8716813b7b2..d18590da331 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -411,7 +411,7 @@ gfc_match_end_interface (void)
       /* Comparing the symbol node names is OK because only use-associated
 	 symbols can be renamed.  */
       if (type != current_interface.type
-	  || strcmp (current_interface.uop->name, name) != 0)
+	  || current_interface.uop->name != name)
 	{
 	  gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
 		     current_interface.uop->name);
@@ -423,7 +423,7 @@ gfc_match_end_interface (void)
     case INTERFACE_DTIO:
     case INTERFACE_GENERIC:
       if (type != current_interface.type
-	  || strcmp (current_interface.sym->name, name) != 0)
+	  || current_interface.sym->name != name)
 	{
 	  gfc_error ("Expecting %<END INTERFACE %s%> at %C",
 		     current_interface.sym->name);
@@ -476,7 +476,7 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2,
 {
   /* Compare names, but not for anonymous components such as UNION or MAP.  */
   if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
-      && strcmp (cmp1->name, cmp2->name) != 0)
+      && cmp1->name != cmp2->name)
     return false;
 
   if (cmp1->attr.access != cmp2->attr.access)
@@ -624,9 +624,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */
-  if (strcmp (derived1->name, derived2->name) == 0
+  if (derived1->name == derived2->name
       && derived1->module != NULL && derived2->module != NULL
-      && strcmp (derived1->module, derived2->module) == 0)
+      && derived1->module == derived2->module)
     return true;
 
   /* Compare type via the rules of the standard.  Both types must have
@@ -636,7 +636,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
 
   /* Compare names, but not for anonymous types such as UNION or MAP.  */
   if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
-      && strcmp (derived1->name, derived2->name) != 0)
+      && derived1->name != derived2->name)
     return false;
 
   if (derived1->component_access == ACCESS_PRIVATE
@@ -839,7 +839,7 @@ static gfc_symbol *
 find_keyword_arg (const char *name, gfc_formal_arglist *f)
 {
   for (; f; f = f->next)
-    if (strcmp (f->sym->name, name) == 0)
+    if (f->sym->name == name)
       return f->sym;
 
   return NULL;
@@ -1140,7 +1140,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 	continue;
 
       if (arg[i].sym && (arg[i].sym->attr.optional
-			 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
+			 || (p1 && arg[i].sym->name == p1)))
 	continue;		/* Skip OPTIONAL and PASS arguments.  */
 
       arg[i].flag = k;
@@ -1149,7 +1149,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
       for (j = i + 1; j < n1; j++)
 	if ((arg[j].sym == NULL
 	     || !(arg[j].sym->attr.optional
-		  || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
+		  || (p1 && arg[j].sym->name == p1)))
 	    && (compare_type_rank_if (arg[i].sym, arg[j].sym)
 	        || compare_type_rank_if (arg[j].sym, arg[i].sym)))
 	  arg[j].flag = k;
@@ -1176,7 +1176,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
       ac2 = 0;
 
       for (f = f2; f; f = f->next)
-	if ((!p2 || strcmp (f->sym->name, p2) != 0)
+	if ((!p2 || f->sym->name != p2)
 	    && (compare_type_rank_if (arg[i].sym, f->sym)
 		|| compare_type_rank_if (f->sym, arg[i].sym)))
 	  ac2++;
@@ -1249,9 +1249,9 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
       if (f1->sym->attr.optional)
 	goto next;
 
-      if (p1 && strcmp (f1->sym->name, p1) == 0)
+      if (p1 && f1->sym->name == p1)
 	f1 = f1->next;
-      if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
+      if (f2 && p2 && f2->sym->name == p2)
 	f2 = f2->next;
 
       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
@@ -1265,7 +1265,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 	 the current non-match.  */
       for (g = f1; g; g = g->next)
 	{
-	  if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
+	  if (g->sym->attr.optional || (p1 && g->sym->name == p1))
 	    continue;
 
 	  sym = find_keyword_arg (g->sym->name, f2_save);
@@ -2914,7 +2914,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	    {
 	      if (f->sym == NULL)
 		continue;
-	      if (strcmp (f->sym->name, a->name) == 0)
+	      if (f->sym->name == a->name)
 		break;
 	    }
 
@@ -4644,14 +4644,14 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
        proc_formal = proc_formal->next, old_formal = old_formal->next)
     {
       if (proc->n.tb->pass_arg
-	  && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
+	  && proc->n.tb->pass_arg == proc_formal->sym->name)
 	proc_pass_arg = argpos;
       if (old->n.tb->pass_arg
-	  && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
+	  && old->n.tb->pass_arg == old_formal->sym->name)
 	old_pass_arg = argpos;
 
       /* Check that the names correspond.  */
-      if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+      if (proc_formal->sym->name != old_formal->sym->name)
 	{
 	  gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
 		     " to match the corresponding argument of the overridden"
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 6596bd87c09..f27249ec6ed 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1716,7 +1716,7 @@ gfc_match_else (void)
       return MATCH_ERROR;
     }
 
-  if (strcmp (name, gfc_current_block ()->name) != 0)
+  if (name != gfc_current_block ()->name)
     {
       gfc_error ("Label %qs at %C doesn't match IF label %qs",
 		 name, gfc_current_block ()->name);
@@ -1751,7 +1751,7 @@ gfc_match_elseif (void)
       goto cleanup;
     }
 
-  if (strcmp (name, gfc_current_block ()->name) != 0)
+  if (name != gfc_current_block ()->name)
     {
       gfc_error ("Label %qs at %C doesn't match IF label %qs",
 		 name, gfc_current_block ()->name);
@@ -5914,7 +5914,7 @@ match_case_eos (void)
   if (m != MATCH_YES)
     return m;
 
-  if (strcmp (name, gfc_current_block ()->name) != 0)
+  if (name != gfc_current_block ()->name)
     {
       gfc_error ("Expected block name %qs of SELECT construct at %C",
 		 gfc_current_block ()->name);
@@ -6640,7 +6640,7 @@ gfc_match_elsewhere (void)
       if (gfc_match_eos () != MATCH_YES)
 	goto syntax;
 
-      if (strcmp (name, gfc_current_block ()->name) != 0)
+      if (name != gfc_current_block ()->name)
 	{
 	  gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
 		     name, gfc_current_block ()->name);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 3ad47f57930..fe5ae34dd13 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3689,7 +3689,7 @@ mio_namelist (gfc_symbol *sym)
       if (sym->attr.flavor == FL_NAMELIST)
 	{
 	  check_name = find_use_name (sym->name, false);
-	  if (check_name && strcmp (check_name, sym->name) != 0)
+	  if (check_name && check_name != sym->name)
 	    gfc_error ("Namelist %s cannot be renamed by USE "
 		       "association to %s", sym->name, check_name);
 	}
@@ -4379,16 +4379,15 @@ static gfc_symtree *
 find_symbol (gfc_symtree *st, const char *name,
 	     const char *module, int generic)
 {
-  int c;
   gfc_symtree *retval, *s;
 
   if (st == NULL || st->n.sym == NULL)
     return NULL;
 
-  c = strcmp (name, st->n.sym->name);
-  if (c == 0 && st->n.sym->module
-	     && strcmp (module, st->n.sym->module) == 0
-	     && !check_unique_name (st->name))
+  if (name == st->n.sym->name
+      && st->n.sym->module
+      && module == st->n.sym->module
+      && !check_unique_name (st->name))
     {
       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
 
@@ -4804,7 +4803,7 @@ load_omp_udrs (void)
 	{
 	  require_atom (ATOM_INTEGER);
 	  pointer_info *p = get_integer (atom_int);
-	  if (strcmp (p->u.rsym.module, udr->omp_out->module))
+	  if (p->u.rsym.module != udr->omp_out->module)
 	    {
 	      gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
 			 "module %s at %L",
@@ -5203,9 +5202,9 @@ read_module (void)
 	    {
 	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
 	      if (st != NULL
-		  && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
+		  && st->n.sym->name == info->u.rsym.true_name
 		  && st->n.sym->module != NULL
-		  && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
+		  && st->n.sym->module == info->u.rsym.module)
 		{
 		  info->u.rsym.symtree = st;
 		  info->u.rsym.sym = st->n.sym;
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 08bc05cbc28..a868e34193f 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2297,7 +2297,7 @@ gfc_match_oacc_routine (void)
 	    {
 	      sym = st->n.sym;
 	      if (gfc_current_ns->proc_name != NULL
-		  && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
+		  && sym->name == gfc_current_ns->proc_name->name)
 	        sym = NULL;
 	    }
 
@@ -2628,8 +2628,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
   if (m != MATCH_YES)
     return false;
 
-  if (strcmp (sname, omp_sym1->name) == 0
-      || strcmp (sname, omp_sym2->name) == 0)
+  if (sname == omp_sym1->name || sname == omp_sym2->name)
     return false;
 
   gfc_current_ns = ns->parent;
@@ -2763,7 +2762,7 @@ gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
       {
 	if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
 	  {
-	    if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
+	    if (omp_udr->ts.u.derived->name == ts->u.derived->name)
 	      return omp_udr;
 	  }
 	else if (omp_udr->ts.kind == ts->kind)
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 880671b57f4..389eead0691 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3569,8 +3569,7 @@ decl:
 
   if (current_interface.ns
 	&& current_interface.ns->proc_name
-	&& strcmp (current_interface.ns->proc_name->name,
-		   prog_unit->name) == 0)
+	&& current_interface.ns->proc_name->name == prog_unit->name)
     gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
 	       "enclosing procedure", prog_unit->name,
 	       &current_interface.ns->proc_name->declared_at);
@@ -3617,7 +3616,7 @@ match_deferred_characteristics (gfc_typespec * ts)
      function name, there is an error.  */
   if (m == MATCH_YES
       && gfc_match ("function% %n", &name) == MATCH_YES
-      && strcmp (name, gfc_current_block ()->name) == 0)
+      && name == gfc_current_block ()->name)
     {
       gfc_current_block ()->declared_at = gfc_current_locus;
       gfc_commit_symbols ();
@@ -5224,8 +5223,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
     case EXEC_OMP_END_CRITICAL:
       if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL))
 	  || (new_st.ext.omp_name != NULL
-	      && strcmp (cp->ext.omp_clauses->critical_name,
-			 new_st.ext.omp_name) != 0))
+	      && cp->ext.omp_clauses->critical_name != new_st.ext.omp_name))
 	gfc_error ("Name after !$omp critical and !$omp end critical does "
 		   "not match at %C");
       new_st.ext.omp_name = NULL;
@@ -5998,7 +5996,7 @@ add_global_procedure (bool sub)
   /* Don't add the symbol multiple times.  */
   if (gfc_new_block->binding_label
       && (!gfc_notification_std (GFC_STD_F2008)
-          || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
+          || gfc_new_block->name != gfc_new_block->binding_label))
     {
       s = gfc_get_gsymbol (gfc_new_block->binding_label);
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ded27624283..afb745bddc5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -149,7 +149,7 @@ check_proc_interface (gfc_symbol *ifc, locus *where)
       /* For generic interfaces, check if there is
 	 a specific procedure with the same name.  */
       gfc_interface *gen = ifc->generic;
-      while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+      while (gen && gen->sym->name != ifc->name)
 	gen = gen->next;
       if (!gen)
 	{
@@ -310,7 +310,7 @@ resolve_formal_arglist (gfc_symbol *proc)
 	       && !resolve_procedure_interface (sym))
 	return;
 
-      if (strcmp (proc->name, sym->name) == 0)
+      if (proc->name == sym->name)
         {
           gfc_error ("Self-referential argument "
                      "%qs at %L is not allowed", sym->name,
@@ -573,7 +573,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
       && sym->ns->parent
       && sym->ns->parent->proc_name
       && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
-      && !strcmp (sym->name, sym->ns->parent->proc_name->name))
+      && sym->name == sym->ns->parent->proc_name->name)
     gfc_error ("Contained procedure %qs at %L has the same name as its "
 	       "encompassing procedure", sym->name, &sym->declared_at);
 
@@ -1015,8 +1015,8 @@ resolve_common_blocks (gfc_symtree *common_root)
 	  && gsym->type == GSYM_COMMON
 	  && ((common_root->n.common->binding_label
 	       && (!gsym->binding_label
-		   || strcmp (common_root->n.common->binding_label,
-			      gsym->binding_label) != 0))
+		   || common_root->n.common->binding_label !=
+			      gsym->binding_label))
 	      || (!common_root->n.common->binding_label
 		  && gsym->binding_label)))
 	{
@@ -1650,7 +1650,7 @@ count_specific_procs (gfc_expr *e)
   sym = e->symtree->n.sym;
 
   for (p = sym->generic; p; p = p->next)
-    if (strcmp (sym->name, p->sym->name) == 0)
+    if (sym->name == p->sym->name)
       {
 	e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
 				       sym->name);
@@ -2337,15 +2337,14 @@ not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
 
       for (; entry; entry = entry->next)
 	{
-	  if (strcmp (sym->name, entry->sym->name) == 0)
+	  if (sym->name == entry->sym->name)
 	    {
-	      if (strcmp (gsym_ns->proc_name->name,
-			  sym->ns->proc_name->name) == 0)
+	      if (gsym_ns->proc_name->name == sym->ns->proc_name->name)
 		return false;
 
 	      if (sym->ns->parent
-		  && strcmp (gsym_ns->proc_name->name,
-			     sym->ns->parent->proc_name->name) == 0)
+		  && gsym_ns->proc_name->name ==
+			     sym->ns->parent->proc_name->name)
 		return false;
 	    }
 	}
@@ -2550,7 +2549,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 	{
 	  gfc_entry_list *entry;
 	  for (entry = gsym->ns->entries; entry; entry = entry->next)
-	    if (strcmp (entry->sym->name, sym->name) == 0)
+	    if (entry->sym->name == sym->name)
 	      {
 		def_sym = entry->sym;
 		break;
@@ -8912,8 +8911,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	      if (c->ts.type == d->ts.type
 		  && ((c->ts.type == BT_DERIVED
 		       && c->ts.u.derived && d->ts.u.derived
-		       && !strcmp (c->ts.u.derived->name,
-				   d->ts.u.derived->name))
+		       && c->ts.u.derived->name == d->ts.u.derived->name)
 		      || c->ts.type == BT_UNKNOWN
 		      || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
 			  && c->ts.kind == d->ts.kind)))
@@ -11733,7 +11731,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
     }
   else if (sym->attr.flavor == FL_VARIABLE && module
 	   && (strcmp (module, gsym->mod_name) != 0
-	       || strcmp (sym->name, gsym->sym_name) != 0))
+	       || sym->name != gsym->sym_name))
     {
       /* This can only happen if the variable is defined in a module - if it
 	 isn't the same module, reject it.  */
@@ -11748,7 +11746,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
 	       || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
 	   && sym != gsym->ns->proc_name
 	   && (module != gsym->mod_name
-	       || strcmp (gsym->sym_name, sym->name) != 0
+	       || gsym->sym_name != sym->name
 	       || (module && strcmp (module, gsym->mod_name) != 0)))
     {
       /* Print an error if the procedure is defined multiple times; we have to
@@ -11895,7 +11893,7 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
     {
       ns = ns->contained;
       for (;ns; ns = ns->sibling)
-	if (strcmp (ns->proc_name->name, sym->name) == 0)
+	if (ns->proc_name->name == sym->name)
 	  break;
     }
 
@@ -12388,7 +12386,7 @@ compare_fsyms (gfc_symbol *sym)
   if (sym == fsym)
     return;
 
-  if (strcmp (sym->name, fsym->name) == 0)
+  if (sym->name == fsym->name)
     {
       if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
 	gfc_error ("%s at %L", errmsg, &fsym->declared_at);
@@ -13382,7 +13380,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	  stree->n.tb->pass_arg_num = 1;
 	  for (i = dummy_args; i; i = i->next)
 	    {
-	      if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
+	      if (i->sym->name == stree->n.tb->pass_arg)
 		{
 		  me_arg = i->sym;
 		  break;
@@ -13812,7 +13810,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
           c->tb->pass_arg_num = 1;
           for (i = c->ts.interface->formal; i; i = i->next)
             {
-              if (!strcmp (i->sym->name, c->tb->pass_arg))
+              if (i->sym->name == c->tb->pass_arg)
                 {
                   me_arg = i->sym;
                   break;
@@ -13914,7 +13912,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
       && ((sym->attr.is_class
            && c == sym->components->ts.u.derived->components)
           || (!sym->attr.is_class && c == sym->components))
-      && strcmp (super_type->name, c->name) == 0)
+      && super_type->name == c->name)
     c->attr.access = super_type->attr.access;
 
   /* If this type is an extension, see if this component has the same name
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index e576bc1cb69..00a178772df 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2239,7 +2239,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
 
   for (p = sym->components; p; p = p->next)
     {
-      if (strcmp (p->name, name) == 0)
+      if (p->name == name)
 	{
 	  gfc_error ("Component %qs at %C already declared at %L",
 		     name, &p->loc);
@@ -2504,7 +2504,8 @@ gfc_find_component (gfc_symbol *sym, const char *name,
               return check;
             }
         }
-      else if (strcmp (p->name, name) == 0)
+      else if (p->name == name || strcmp (p->name, name) == 0)
+	/* FORNOW: name could be "_data" et al so fallback to strcmp.  */
         break;
 
       continue;
@@ -2902,7 +2903,6 @@ compare_symtree (void *_st1, void *_st2)
 
   st1 = (gfc_symtree *) _st1;
   st2 = (gfc_symtree *) _st2;
-
   return strcmp (st1->name, st2->name);
 }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index adb2c0575a8..78132908929 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -9024,7 +9024,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      gfc_actual_arglist *param = pdt_param_list;
 	      gfc_init_se (&tse, NULL);
 	      for (; param; param = param->next)
-		if (param->name && !strcmp (c->name, param->name))
+		if (param->name && c->name == param->name)
 		  c_expr = param->expr;
 
 	      if (!c_expr)
@@ -9266,7 +9266,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      gfc_init_se (&tse, NULL);
 	      for (; param; param = param->next)
-		if (!strcmp (c->name, param->name)
+		if (c->name == param->name
 		    && param->spec_type == SPEC_EXPLICIT)
 		  c_expr = param->expr;
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index e2adfa2e2db..6e717633a8f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1994,7 +1994,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
 
 	  for (; entry; entry = entry->next)
 	    {
-	      if (strcmp (gsym->name, entry->sym->name) == 0)
+	      if (gsym->name == entry->sym->name)
 		{
 	          sym->backend_decl = entry->sym->backend_decl;
 		  break;
@@ -2787,9 +2787,10 @@ build_entry_thunks (gfc_namespace * ns, bool global)
 
 	  for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
 	       field; field = DECL_CHAIN (field))
-	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
-		thunk_sym->result->name) == 0)
+	    if (IDENTIFIER_POINTER (DECL_NAME (field)) ==
+		thunk_sym->result->name)
 	      break;
+
 	  gcc_assert (field != NULL_TREE);
 	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
 				 TREE_TYPE (field), union_decl, field,
@@ -2912,7 +2913,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
       tree t = NULL, var;
       if (this_fake_result_decl != NULL)
 	for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
-	  if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+	  if (IDENTIFIER_POINTER (TREE_PURPOSE (t)) == sym->name)
 	    break;
       if (t)
 	return TREE_VALUE (t);
@@ -2929,10 +2930,8 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
 
 	  for (field = TYPE_FIELDS (TREE_TYPE (decl));
 	       field; field = DECL_CHAIN (field))
-	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
-		sym->name) == 0)
+	    if (IDENTIFIER_POINTER (DECL_NAME (field)) == sym->name)
 	      break;
-
 	  gcc_assert (field != NULL_TREE);
 	  decl = fold_build3_loc (input_location, COMPONENT_REF,
 				  TREE_TYPE (field), decl, field, NULL_TREE);
@@ -4794,7 +4793,7 @@ struct module_hasher : ggc_ptr_hash<module_htab_entry>
   static bool
   equal (module_htab_entry *a, const char *b)
   {
-    return !strcmp (a->name, b);
+    return a->name == b;
   }
 };
 
@@ -4817,7 +4816,7 @@ module_decl_hasher::equal (tree t1, const char *x2)
   const_tree n1 = DECL_NAME (t1);
   if (n1 == NULL_TREE)
     n1 = TYPE_NAME (TREE_TYPE (t1));
-  return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
+  return IDENTIFIER_POINTER (n1) == x2;
 }
 
 struct module_htab_entry *
@@ -5071,7 +5070,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      if (st->n.sym->backend_decl
 		  && DECL_P (st->n.sym->backend_decl)
 		  && st->n.sym->module
-		  && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
+		  && st->n.sym->module == use_stmt->module_name)
 		{
 		  gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
 			      || !VAR_P (st->n.sym->backend_decl));
@@ -5084,8 +5083,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      else if (st->n.sym->attr.flavor == FL_NAMELIST
 		       && st->n.sym->attr.use_only
 		       && st->n.sym->module
-		       && strcmp (st->n.sym->module, use_stmt->module_name)
-			  == 0)
+		       && st->n.sym->module == use_stmt->module_name)
 		{
 		  decl = generate_namelist_decl (st->n.sym);
 		  DECL_CONTEXT (decl) = entry->namespace_decl;
@@ -5613,7 +5611,7 @@ generate_local_decl (gfc_symbol * sym)
 	      gfc_entry_list *el;
 
 	      for (el = sym->ns->entries; el; el=el->next)
-		if (strcmp(sym->name, el->sym->name) == 0)
+		if (sym->name == el->sym->name)
 		  enter = true;
 
 	      if (!enter)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 56ce98c78c6..6c8a5b30568 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2490,7 +2490,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
 
   /* Return if the component is in the parent type.  */
   for (cmp = dt->components; cmp; cmp = cmp->next)
-    if (strcmp (c->name, cmp->name) == 0)
+    if (c->name == cmp->name)
       return;
 
   /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
@@ -5199,8 +5199,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			   && fsym->ts.type == BT_CLASS
 			   && !CLASS_DATA (fsym)->as
 			   && !CLASS_DATA (e)->as
-			   && strcmp (fsym->ts.u.derived->name,
-				      e->ts.u.derived->name))
+			   && fsym->ts.u.derived->name != e->ts.u.derived->name)
 		    {
 		      type = gfc_typenode_for_spec (&fsym->ts);
 		      var = gfc_create_var (type, fsym->name);
@@ -6001,7 +6000,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    {
 	      formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
 	      for (; formal; formal = formal->next)
-		if (strcmp (formal->sym->name, sym->name) == 0)
+		if (formal->sym->name == sym->name)
 		  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
 	    }
 	  len = cl.backend_decl;
-- 
2.19.0.rc1

[PATCH,FORTRAN 26/29] Use stringpool for mangled common names

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.c (gfc_get_common): Use stringpool for mangled name.
---
 gcc/fortran/match.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index fd91e280b93..8d073f28f67 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5008,13 +5008,13 @@ gfc_get_common (const char *name, int from_module)
 {
   gfc_symtree *st;
   static int serial = 0;
-  char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *mangled_name;
 
   if (from_module)
     {
       /* A use associated common block is only needed to correctly layout
 	 the variables it contains.  */
-      snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+      mangled_name = gfc_get_string ("_%d_%s", serial++, name);
       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
     }
   else
-- 
2.19.0.rc1

[PATCH,FORTRAN 23/29] Use stringpool for module binding_label

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-28  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* module.c (struct pointer_info): Change binding_label to const
	pointer.
	(free_pi_tree): Do not free binding_label.
	(load_commons): Use stringpool for binding_label.
	(load_needed): Likewise.
	(read_module): Likewise.
---
 gcc/fortran/module.c | 31 ++++++++++++-------------------
 1 file changed, 12 insertions(+), 19 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 24e48c94c76..8f6dc9f2864 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -158,7 +158,8 @@ typedef struct pointer_info
     struct
     {
       gfc_symbol *sym;
-      char *true_name, *module, *binding_label;
+      const char *binding_label;
+      char *true_name, *module;
       fixup_t *stfixup;
       gfc_symtree *symtree;
       enum gfc_rsym_state state;
@@ -242,7 +243,6 @@ free_pi_tree (pointer_info *p)
     {
       XDELETEVEC (p->u.rsym.true_name);
       XDELETEVEC (p->u.rsym.module);
-      XDELETEVEC (p->u.rsym.binding_label);
     }
 
   free (p);
@@ -4646,7 +4646,7 @@ load_commons (void)
   while (peek_atom () != ATOM_RPAREN)
     {
       int flags;
-      char* label;
+      const char* bind_label;
       mio_lparen ();
       mio_pool_string (&name);
 
@@ -4663,10 +4663,9 @@ load_commons (void)
       /* Get whether this was a bind(c) common or not.  */
       mio_integer (&p->is_bind_c);
       /* Get the binding label.  */
-      label = read_string ();
-      if (strlen (label))
-	p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
-      XDELETEVEC (label);
+      mio_pool_string (&bind_label);
+      if (bind_label)
+	p->binding_label = bind_label;
 
       mio_rparen ();
     }
@@ -4899,8 +4898,7 @@ load_needed (pointer_info *p)
       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 = IDENTIFIER_POINTER (get_identifier
-						 (p->u.rsym.binding_label));
+	sym->binding_label = p->u.rsym.binding_label;
 
       associate_integer_pointer (p, sym);
     }
@@ -5052,7 +5050,7 @@ read_module (void)
   pointer_info *info, *q;
   gfc_use_rename *u = NULL;
   gfc_symtree *st;
-  gfc_symbol *sym;
+  gfc_symbol *sym = NULL;
 
   get_module_locus (&operator_interfaces);	/* Skip these for now.  */
   skip_list ();
@@ -5075,7 +5073,7 @@ read_module (void)
 
   while (peek_atom () != ATOM_RPAREN)
     {
-      char* bind_label;
+      const char* bind_label;
       require_atom (ATOM_INTEGER);
       info = get_integer (atom_int);
 
@@ -5084,11 +5082,9 @@ read_module (void)
 
       info->u.rsym.true_name = read_string ();
       info->u.rsym.module = read_string ();
-      bind_label = read_string ();
-      if (strlen (bind_label))
+      mio_pool_string (&bind_label);
+      if (bind_label)
 	info->u.rsym.binding_label = bind_label;
-      else
-	XDELETEVEC (bind_label);
 
       require_atom (ATOM_INTEGER);
       info->u.rsym.ns = atom_int;
@@ -5265,10 +5261,7 @@ read_module (void)
 		  sym->module = gfc_get_string ("%s", info->u.rsym.module);
 
 		  if (info->u.rsym.binding_label)
-		    {
-		      tree id = get_identifier (info->u.rsym.binding_label);
-		      sym->binding_label = IDENTIFIER_POINTER (id);
-		    }
+		    sym->binding_label = info->u.rsym.binding_label;
 		}
 
 	      st->n.sym = sym;
-- 
2.19.0.rc1

[PATCH,FORTRAN 21/29] Use stringpool for module tbp

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Switch type bound procedures to use the stringpool.

gcc/fortran/ChangeLog:

2017-11-24  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* decl.c (gfc_match_decl_type_spec): Use stringpool.
	* module.c (mio_expr): Likewise.
	(mio_typebound_proc): Likewise.
	(mio_full_typebound_tree): Likewise.
	(mio_omp_udr_expr): Likewise.
---
 gcc/fortran/decl.c   |  9 +++++----
 gcc/fortran/module.c | 24 ++++++++++++------------
 2 files changed, 17 insertions(+), 16 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d6a6538f769..cc14a871dfd 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4049,12 +4049,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	{
 	  gfc_symbol *upe;
 	  gfc_symtree *st;
+	  const char *star_name = gfc_get_string ("%s", "STAR");
 	  ts->type = BT_CLASS;
-	  gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
+	  gfc_find_symbol (star_name, gfc_current_ns, 1, &upe);
 	  if (upe == NULL)
 	    {
-	      upe = gfc_new_symbol ("STAR", gfc_current_ns);
-	      st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+	      upe = gfc_new_symbol (star_name, gfc_current_ns);
+	      st = gfc_new_symtree (&gfc_current_ns->sym_root, star_name);
 	      st->n.sym = upe;
 	      gfc_set_sym_referenced (upe);
 	      upe->refs++;
@@ -4069,7 +4070,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	    }
 	  else
 	    {
-	      st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
+	      st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, star_name);
 	      st->n.sym = upe;
 	      upe->refs++;
 	    }
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 3b644234921..24e48c94c76 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3585,9 +3585,9 @@ mio_expr (gfc_expr **ep)
 	    case 3:
 	      break;
 	    default:
-	      require_atom (ATOM_STRING);
-	      e->value.function.isym = gfc_find_function (atom_string);
-	      free (atom_string);
+	      const char *name;
+	      mio_pool_string (&name);
+	      e->value.function.isym = gfc_find_function (name);
 	    }
 	}
 
@@ -3872,6 +3872,7 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 	  while (peek_atom () != ATOM_RPAREN)
 	    {
 	      gfc_symtree** sym_root;
+	      const char *name;
 
 	      g = gfc_get_tbp_generic ();
 	      g->specific = NULL;
@@ -3879,10 +3880,9 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 	      mio_integer (&iop);
 	      g->is_operator = (bool) iop;
 
-	      require_atom (ATOM_STRING);
+	      mio_pool_string (&name);
 	      sym_root = &current_f2k_derived->tb_sym_root;
-	      g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
-	      free (atom_string);
+	      g->specific_st = gfc_get_tbp_symtree (sym_root, name);
 
 	      g->next = (*proc)->u.generic;
 	      (*proc)->u.generic = g;
@@ -3928,12 +3928,12 @@ mio_full_typebound_tree (gfc_symtree** root)
       while (peek_atom () == ATOM_LPAREN)
 	{
 	  gfc_symtree* st;
+	  const char *name;
 
 	  mio_lparen ();
 
-	  require_atom (ATOM_STRING);
-	  st = gfc_get_tbp_symtree (root, atom_string);
-	  free (atom_string);
+	  mio_pool_string (&name);
+	  st = gfc_get_tbp_symtree (root, name);
 
 	  mio_typebound_symtree (st);
 	}
@@ -4267,9 +4267,9 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
 	  mio_integer (&flag);
 	  if (flag)
 	    {
-	      require_atom (ATOM_STRING);
-	      ns->code->resolved_isym = gfc_find_subroutine (atom_string);
-	      free (atom_string);
+	      const char *name;
+	      mio_pool_string (&name);
+	      ns->code->resolved_isym = gfc_find_subroutine (name);
 	    }
 	  else
 	    mio_symbol_ref (&ns->code->resolved_sym);
-- 
2.19.0.rc1

[PATCH,FORTRAN 29/29] PR87103: Remove max symbol length check from gfc_new_symbol

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gfc_match_name does check for too long names already. Since
gfc_new_symbol is also called for symbols with internal names containing
compiler-generated prefixes, these internal names can easily exceed the
max_identifier_length mandated by the standard.

gcc/fortran/ChangeLog

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

	PR fortran/87103
	* expr.c (gfc_check_conformance): Check vsnprintf for truncation.
	* iresolve.c (gfc_get_string): Likewise.
	* symbol.c (gfc_new_symbol): Remove check for maximum symbol
	name length.  Remove redundant 0 setting of new calloc()ed
	gfc_symbol.
---
 gcc/fortran/expr.c     |  4 +++-
 gcc/fortran/iresolve.c |  5 ++++-
 gcc/fortran/symbol.c   | 16 ----------------
 3 files changed, 7 insertions(+), 18 deletions(-)

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c5bf822cd24..6b5671390ec 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3225,8 +3225,10 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, .
     return true;
 
   va_start (argp, optype_msgid);
-  vsnprintf (buffer, 240, optype_msgid, argp);
+  d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
   va_end (argp);
+  if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation.  */
+    gfc_internal_error ("optype_msgid overflow: %d", d);
 
   if (op1->rank != op2->rank)
     {
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 61663fec7e5..d7bd0545173 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -60,9 +60,12 @@ gfc_get_string (const char *format, ...)
     }
   else
     {
+      int ret;
       va_start (ap, format);
-      vsnprintf (temp_name, sizeof (temp_name), format, ap);
+      ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
       va_end (ap);
+      if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation.  */
+	gfc_internal_error ("identifier overflow: %d", ret);
       temp_name[sizeof (temp_name) - 1] = 0;
       str = temp_name;
     }
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cde34c67482..fc3354f0457 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3142,25 +3142,9 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   gfc_clear_ts (&p->ts);
   gfc_clear_attr (&p->attr);
   p->ns = ns;
-
   p->declared_at = gfc_current_locus;
-
-  if (strlen (name) > GFC_MAX_SYMBOL_LEN)
-    gfc_internal_error ("new_symbol(): Symbol name too long");
-
   p->name = gfc_get_string ("%s", name);
 
-  /* Make sure flags for symbol being C bound are clear initially.  */
-  p->attr.is_bind_c = 0;
-  p->attr.is_iso_c = 0;
-
-  /* Clear the ptrs we may need.  */
-  p->common_block = NULL;
-  p->f2k_derived = NULL;
-  p->assoc = NULL;
-  p->dt_next = NULL;
-  p->fn_result_spec = 0;
-
   return p;
 }
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 10/29] Do not copy name for check_function_name

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Copying the sym->name ruins pointer equality checks and first and
foremost is not needed nowadays.

gcc/fortran/ChangeLog:

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

	* decl.c (gfc_match_volatile, gfc_match_asynchronous): Do not
	copy sym->name.
---
 gcc/fortran/decl.c | 10 ++--------
 1 file changed, 2 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2667c2281f8..b0c45b88505 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -9167,7 +9167,6 @@ match
 gfc_match_volatile (void)
 {
   gfc_symbol *sym;
-  char *name;
   match m;
 
   if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
@@ -9189,9 +9188,7 @@ gfc_match_volatile (void)
       switch (m)
 	{
 	case MATCH_YES:
-	  name = XCNEWVAR (char, strlen (sym->name) + 1);
-	  strcpy (name, sym->name);
-	  if (!check_function_name (name))
+	  if (!check_function_name (sym->name))
 	    return MATCH_ERROR;
 	  /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
 	     for variable in a BLOCK which is defined outside of the BLOCK.  */
@@ -9231,7 +9228,6 @@ match
 gfc_match_asynchronous (void)
 {
   gfc_symbol *sym;
-  char *name;
   match m;
 
   if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
@@ -9253,9 +9249,7 @@ gfc_match_asynchronous (void)
       switch (m)
 	{
 	case MATCH_YES:
-	  name = XCNEWVAR (char, strlen (sym->name) + 1);
-	  strcpy (name, sym->name);
-	  if (!check_function_name (name))
+	  if (!check_function_name (sym->name))
 	    return MATCH_ERROR;
 	  if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
 	    return MATCH_ERROR;
-- 
2.19.0.rc1

[PATCH,FORTRAN 27/29] Use stringpool for OMP clause reduction code

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-12-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* trans-openmp.c (gfc_trans_omp_array_reduction_or_udr): Use
	stringpool for clause reduction code.
---
 gcc/fortran/trans-openmp.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index f038f4c5bf8..c8d7e0a409d 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -1616,6 +1616,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
     }
   if (iname != NULL)
     {
+      iname = gfc_get_string ("%s", iname);
       memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
       intrinsic_sym.ns = sym->ns;
       intrinsic_sym.name = iname;
-- 
2.19.0.rc1

[PATCH,FORTRAN 17/29] Use stringpool for iso_fortran_env

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-23  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* module.c (use_iso_fortran_env_module): Use stringpool and use
	pointer comparison instead of strcmp.
---
 gcc/fortran/module.c | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index d7bc7fbef1c..3b644234921 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6678,7 +6678,7 @@ read_module_to_tmpbuf ()
 static void
 use_iso_fortran_env_module (void)
 {
-  static char mod[] = "iso_fortran_env";
+  const char *mod = gfc_get_string ("%s", "iso_fortran_env");
   gfc_use_rename *u;
   gfc_symbol *mod_sym;
   gfc_symtree *mod_symtree;
@@ -6686,11 +6686,11 @@ use_iso_fortran_env_module (void)
   int i, j;
 
   intmod_sym symbol[] = {
-#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
-#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
-#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
-#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
-#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
+#define NAMED_INTCST(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_KINDARRAY(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_FUNCTION(a,b,c,d) { a, gfc_get_string ("%s", b), c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, gfc_get_string ("%s", b), c, d },
 #include "iso-fortran-env.def"
     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
 
@@ -6708,7 +6708,7 @@ use_iso_fortran_env_module (void)
 
       mod_sym->attr.flavor = FL_MODULE;
       mod_sym->attr.intrinsic = 1;
-      mod_sym->module = gfc_get_string ("%s", mod);
+      mod_sym->module = mod;
       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
     }
   else
@@ -6723,7 +6723,7 @@ use_iso_fortran_env_module (void)
       bool found = false;
       for (u = gfc_rename_list; u; u = u->next)
 	{
-	  if (strcmp (symbol[i].name, u->use_name) == 0)
+	  if (symbol[i].name == u->use_name)
 	    {
 	      found = true;
 	      u->found = 1;
-- 
2.19.0.rc1

[PATCH,FORTRAN 19/29] Use stringpool and unified uppercase handling for types

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

Use the existing helper function to create type names. The helper
function uses the stringpool already.

gcc/fortran/ChangeLog:

2017-11-24  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* decl.c (build_sym): Use stringpool node instead of stack
	variables.
	(gfc_match_map): Likewise.
	(gfc_match_union): Likewise.
	* trans-decl.c (gfc_trans_use_stmts): Call gfc_dt_upper_string
	and thus use stringpool node for the type name.
---
 gcc/fortran/decl.c       | 25 ++++++++++---------------
 gcc/fortran/trans-decl.c |  8 +++-----
 2 files changed, 13 insertions(+), 20 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 48ef5637e36..55a59008f66 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1490,7 +1490,7 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
 {
   symbol_attribute attr;
   gfc_symbol *sym;
-  int upper;
+  const char *upper;
   gfc_symtree *st;
 
   /* Symbols in a submodule are host associated from the parent module or
@@ -1520,20 +1520,15 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
      course, this is only necessary if the upper case letter is
      actually different.  */
 
-  upper = TOUPPER(name[0]);
-  if (upper != name[0])
+  upper = gfc_dt_upper_string (name);
+  if (upper[0] != name[0])
     {
-      char u_name[GFC_MAX_SYMBOL_LEN + 1];
       gfc_symtree *st;
-
-      gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
-      strcpy (u_name, name);
-      u_name[0] = upper;
-
-      st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
+      gcc_assert (strlen (upper) <= GFC_MAX_SYMBOL_LEN);
+      st = gfc_find_symtree (gfc_current_ns->sym_root, upper);
 
       /* STRUCTURE types can alias symbol names */
-      if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
+      if (st && st->n.sym->attr.flavor != FL_STRUCT)
 	{
 	  gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
 		     &st->n.sym->declared_at);
@@ -9672,7 +9667,7 @@ gfc_match_map (void)
 {
   /* Counter used to give unique internal names to map structures. */
   static unsigned int gfc_map_id = 0;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   gfc_symbol *sym;
   locus old_loc;
 
@@ -9687,7 +9682,7 @@ gfc_match_map (void)
 
   /* Map blocks are anonymous so we make up unique names for the symbol table
      which are invalid Fortran identifiers.  */
-  snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
+  name = gfc_get_string ("MM$%u", gfc_map_id++);
 
   if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
     return MATCH_ERROR;
@@ -9705,7 +9700,7 @@ gfc_match_union (void)
 {
   /* Counter used to give unique internal names to union types. */
   static unsigned int gfc_union_id = 0;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   gfc_symbol *sym;
   locus old_loc;
 
@@ -9720,7 +9715,7 @@ gfc_match_union (void)
 
   /* Unions are anonymous so we make up unique names for the symbol table
      which are invalid Fortran identifiers.  */
-  snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
+  name = gfc_get_string ("UU$%u", gfc_union_id++);
 
   if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
     return MATCH_ERROR;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 6e717633a8f..023350723ff 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5053,12 +5053,10 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      /* The following can happen if a derived type is renamed.  */
 	      if (!st)
 		{
-		  char *name;
-		  name = xstrdup (rent->local_name
+		  const char *upper;
+		  upper = gfc_dt_upper_string (rent->local_name
 				  ? rent->local_name : rent->use_name);
-		  name[0] = (char) TOUPPER ((unsigned char) name[0]);
-		  st = gfc_find_symtree (ns->sym_root, name);
-		  free (name);
+		  st = gfc_find_symtree (ns->sym_root, upper);
 		  gcc_assert (st);
 		}
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 15/29] Use stringpool for iso_c_binding module names

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-20  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.h (struct CInteropKind_t): Make name a pointer.
	* misc.c (get_c_kind): Use pointer comparison on name to
	determine index.
	* symbol.c (generate_isocbinding_symbol): Use stringpool pointer
	for argument to get_c_kind ().
	* trans-types.c (gfc_init_c_interop_kinds): Use stringpool node
	for name.
	* module.c (import_iso_c_binding_module): Likewise.
---
 gcc/fortran/gfortran.h    |  2 +-
 gcc/fortran/misc.c        |  2 +-
 gcc/fortran/module.c      | 16 +++++++++-------
 gcc/fortran/symbol.c      |  3 ++-
 gcc/fortran/trans-types.c | 20 ++++++++++----------
 5 files changed, 23 insertions(+), 20 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 039719644ea..0e164c35300 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -719,7 +719,7 @@ enum intmod_id
 
 typedef struct
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   int value;  /* Used for both integer and character values.  */
   bt f90_type;
 }
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index fb18c5ceb6f..29aae591ed3 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -278,7 +278,7 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
   int index = 0;
 
   for (index = 0; index < ISOCBINDING_LAST; index++)
-    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
+    if (kinds_table[index].name == c_kind_name)
       return index;
 
   return ISOCBINDING_INVALID;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b94411ac68b..22d9abb247f 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6357,27 +6357,27 @@ import_iso_c_binding_module (void)
 #define NAMED_FUNCTION(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
-		  name = b; \
+		  name = gfc_get_string ("%s", b); \
 		  break;
 #define NAMED_SUBROUTINE(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
-		  name = b; \
+		  name = gfc_get_string ("%s", b); \
 		  break;
 #define NAMED_INTCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
-		  name = b; \
+		  name = gfc_get_string ("%s", b); \
 		  break;
 #define NAMED_REALCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
-		  name = b; \
+		  name = gfc_get_string ("%s", b); \
 		  break;
 #define NAMED_CMPXCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
-		  name = b; \
+		  name = gfc_get_string ("%s", b); \
 		  break;
 #include "iso-c-binding.def"
 		default:
@@ -6481,13 +6481,15 @@ import_iso_c_binding_module (void)
 		  return_type = c_funptr->n.sym; \
 		else \
 		  return_type = NULL; \
-		create_intrinsic_function (b, a, iso_c_module_name, \
+		create_intrinsic_function (gfc_get_string ("%s", b), \
+					   a, iso_c_module_name, \
 					   INTMOD_ISO_C_BINDING, false, \
 					   return_type); \
 		break;
 #define NAMED_SUBROUTINE(a,b,c,d) \
 	      case a: \
-		create_intrinsic_function (b, a, iso_c_module_name, \
+		create_intrinsic_function (gfc_get_string ("%s", b), \
+					   a, iso_c_module_name, \
 					   INTMOD_ISO_C_BINDING, true, NULL); \
 		  break;
 #include "iso-c-binding.def"
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cc9d4e3f9d8..ce134d2b441 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4985,7 +4985,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	  tmp_comp->ts.f90_type = BT_INTEGER;
 
 	  /* The kinds for c_ptr and c_funptr are the same.  */
-	  index = get_c_kind ("c_ptr", c_interop_kinds_table);
+	  index = get_c_kind (gfc_get_string ("%s", "c_ptr"),
+	      c_interop_kinds_table);
 	  tmp_comp->ts.kind = c_interop_kinds_table[index].value;
 	  tmp_comp->attr.access = ACCESS_PRIVATE;
 
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 46f6d8c03a6..deb9993b0e3 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -360,45 +360,45 @@ gfc_init_c_interop_kinds (void)
   for (i = 0; i < ISOCBINDING_NUMBER; i++)
     {
       /* Initialize the name and value fields.  */
-      c_interop_kinds_table[i].name[0] = '\0';
+      c_interop_kinds_table[i].name = NULL;
       c_interop_kinds_table[i].value = -100;
       c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
     }
 
 #define NAMED_INTCST(a,b,c,d) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_INTEGER; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_REALCST(a,b,c,d) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_REAL; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_CMPXCST(a,b,c,d) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_LOGCST(a,b,c) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_CHARKNDCST(a,b,c) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_CHARCST(a,b,c) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
   c_interop_kinds_table[a].value = c;
 #define DERIVED_TYPE(a,b,c) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_DERIVED; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_FUNCTION(a,b,c,d) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
   c_interop_kinds_table[a].value = c;
 #define NAMED_SUBROUTINE(a,b,c,d) \
-  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+  c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
   c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
   c_interop_kinds_table[a].value = c;
 #include "iso-c-binding.def"
-- 
2.19.0.rc1

[PATCH,FORTRAN 16/29] Do pointer comparison in iso_c_binding_module

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-23  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* module.c (import_iso_c_binding_module): Use pointer comparison
	instead instead of strcmp.
---
 gcc/fortran/module.c | 25 ++++++++++---------------
 1 file changed, 10 insertions(+), 15 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 22d9abb247f..d7bc7fbef1c 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6269,7 +6269,7 @@ import_iso_c_binding_module (void)
   gfc_symbol *mod_sym = NULL, *return_type;
   gfc_symtree *mod_symtree = NULL, *tmp_symtree;
   gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
-  const char *iso_c_module_name = "__iso_c_binding";
+  const char *iso_c_module_name = gfc_get_string ("%s", "__iso_c_binding");
   gfc_use_rename *u;
   int i;
   bool want_c_ptr = false, want_c_funptr = false;
@@ -6291,7 +6291,7 @@ import_iso_c_binding_module (void)
 
       mod_sym->attr.flavor = FL_MODULE;
       mod_sym->attr.intrinsic = 1;
-      mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
+      mod_sym->module = iso_c_module_name;
       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
     }
 
@@ -6300,27 +6300,22 @@ import_iso_c_binding_module (void)
      need C_(FUN)PTR.  */
   for (u = gfc_rename_list; u; u = u->next)
     {
-      if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
-		  u->use_name) == 0)
+      if (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name == u->use_name)
         want_c_ptr = true;
-      else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
-		       u->use_name) == 0)
+      else if (c_interop_kinds_table[ISOCBINDING_LOC].name == u->use_name)
         want_c_ptr = true;
-      else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
-		       u->use_name) == 0)
+      else if (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name ==
+	  u->use_name)
         want_c_funptr = true;
-      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
-		       u->use_name) == 0)
+      else if (c_interop_kinds_table[ISOCBINDING_FUNLOC].name == u->use_name)
         want_c_funptr = true;
-      else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
-                       u->use_name) == 0)
+      else if (c_interop_kinds_table[ISOCBINDING_PTR].name == u->use_name)
 	{
 	  c_ptr = generate_isocbinding_symbol (iso_c_module_name,
 	      (iso_c_binding_symbol) ISOCBINDING_PTR,
 	      u->local_name ? u->local_name : u->use_name, NULL, false);
 	}
-      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
-                       u->use_name) == 0)
+      else if (c_interop_kinds_table[ISOCBINDING_FUNPTR].name == u->use_name)
 	{
 	  c_funptr = generate_isocbinding_symbol (iso_c_module_name,
 	      (iso_c_binding_symbol) ISOCBINDING_FUNPTR,
@@ -6345,7 +6340,7 @@ import_iso_c_binding_module (void)
     {
       bool found = false;
       for (u = gfc_rename_list; u; u = u->next)
-	if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+	if (c_interop_kinds_table[i].name == u->use_name)
 	  {
 	    bool not_in_std;
 	    const char *name;
-- 
2.19.0.rc1

[PATCH,FORTRAN 18/29] Use stringpool for charkind

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-24  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* primary.c (match_charkind_name): Return stringpool node.
	(match_string_constant): Use stringpool node for name.
---
 gcc/fortran/primary.c | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index da661372c5c..cd5f81542cb 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -950,8 +950,9 @@ next_string_char (gfc_char_t delimiter, int *ret)
    the name will be detected later.  */
 
 static match
-match_charkind_name (char *name)
+match_charkind_name (const char **result)
 {
+  char buffer [GFC_MAX_SYMBOL_LEN + 1];
   locus old_loc;
   char c, peek;
   int len;
@@ -961,8 +962,8 @@ match_charkind_name (char *name)
   if (!ISALPHA (c))
     return MATCH_NO;
 
-  *name++ = c;
-  len = 1;
+  len = 0;
+  buffer[len++] = c;
 
   for (;;)
     {
@@ -976,7 +977,8 @@ match_charkind_name (char *name)
 	  if (peek == '\'' || peek == '\"')
 	    {
 	      gfc_current_locus = old_loc;
-	      *name = '\0';
+	      buffer[len] = '\0';
+	      *result = gfc_get_string ("%s", buffer);
 	      return MATCH_YES;
 	    }
 	}
@@ -986,8 +988,8 @@ match_charkind_name (char *name)
 	  && (c != '$' || !flag_dollar_ok))
 	break;
 
-      *name++ = c;
-      if (++len > GFC_MAX_SYMBOL_LEN)
+      buffer[len++] = c;
+      if (len > GFC_MAX_SYMBOL_LEN)
 	break;
     }
 
@@ -1005,9 +1007,10 @@ match_charkind_name (char *name)
 static match
 match_string_constant (gfc_expr **result)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1], peek;
+  char peek;
+  const char *name = NULL;
   size_t length;
-  int kind,save_warn_ampersand, ret;
+  int kind, save_warn_ampersand, ret;
   locus old_locus, start_locus;
   gfc_symbol *sym;
   gfc_expr *e;
@@ -1043,7 +1046,7 @@ match_string_constant (gfc_expr **result)
     {
       gfc_current_locus = old_locus;
 
-      m = match_charkind_name (name);
+      m = match_charkind_name (&name);
       if (m != MATCH_YES)
 	goto no_match;
 
-- 
2.19.0.rc1

[PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

compiling gfortran.dg/typebound_proc_31.f90 leaked the type-bound
structs:

56 bytes in 1 blocks are definitely lost.
  at 0x4C2CC05: calloc (vg_replace_malloc.c:711)
  by 0x151EA90: xcalloc (xmalloc.c:162)
  by 0x8E3E4F: gfc_get_typebound_proc(gfc_typebound_proc*) (symbol.c:4945)
  by 0x84C095: match_procedure_in_type (decl.c:10486)
  by 0x84C095: gfc_match_procedure() (decl.c:6696)
...

gcc/fortran/ChangeLog:

2017-12-06  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* symbol.c (free_tb_tree): Free type-bound procedure struct.
	(gfc_get_typebound_proc): Use explicit memcpy for clarity.
---
 gcc/fortran/symbol.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 53c760a6c38..cde34c67482 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3845,7 +3845,7 @@ free_tb_tree (gfc_symtree *t)
 
   /* TODO: Free type-bound procedure structs themselves; probably needs some
      sort of ref-counting mechanism.  */
-
+  free (t->n.tb);
   free (t);
 }
 
@@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
 
   result = XCNEW (gfc_typebound_proc);
   if (tb0)
-    *result = *tb0;
+    memcpy (result, tb0, sizeof (gfc_typebound_proc));;
   result->error = 1;
 
   latest_undo_chgset->tbps.safe_push (result);
-- 
2.19.0.rc1

[PATCH,FORTRAN 20/29] Use stringpool in class et al

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-24  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* class.c (finalizer_insert_packed_call): Use stringpool.
	(generate_finalization_wrapper): Likewise.
	(gfc_find_derived_vtab): Likewise.
	(find_intrinsic_vtab): Likewise.
	* decl.c (gfc_match_null): Likewise.
	* parse.c (gfc_build_block_ns): Likewise.
	* resolve.c (resolve_entries): Likewise.
	* symbol.c (gfc_get_unique_symtree): Likewise.
---
 gcc/fortran/class.c   | 40 ++++++++++++++++++++--------------------
 gcc/fortran/decl.c    |  2 +-
 gcc/fortran/parse.c   |  6 +++---
 gcc/fortran/resolve.c |  5 ++---
 gcc/fortran/symbol.c  |  4 ++--
 5 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index c2dc3411811..20a68da8e9b 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1373,7 +1373,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->ext.block.ns = ns;
   block->ext.block.assoc = NULL;
 
-  gfc_get_symbol ("ptr2", ns, &ptr2);
+  gfc_get_symbol (gfc_get_string ("%s", "ptr2"), ns, &ptr2);
   ptr2->ts.type = BT_DERIVED;
   ptr2->ts.u.derived = array->ts.u.derived;
   ptr2->attr.flavor = FL_VARIABLE;
@@ -1382,7 +1382,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   gfc_set_sym_referenced (ptr2);
   gfc_commit_symbol (ptr2);
 
-  gfc_get_symbol ("tmp_array", ns, &tmp_array);
+  gfc_get_symbol (gfc_get_string ("%s", "tmp_array"), ns, &tmp_array);
   tmp_array->ts.type = BT_DERIVED;
   tmp_array->ts.u.derived = array->ts.u.derived;
   tmp_array->attr.flavor = FL_VARIABLE;
@@ -1625,7 +1625,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_commit_symbol (final);
 
   /* Set up formal argument.  */
-  gfc_get_symbol ("array", sub_ns, &array);
+  gfc_get_symbol (gfc_get_string ("%s", "array"), sub_ns, &array);
   array->ts.type = BT_DERIVED;
   array->ts.u.derived = derived;
   array->attr.flavor = FL_VARIABLE;
@@ -1643,7 +1643,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_commit_symbol (array);
 
   /* Set up formal argument.  */
-  gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+  gfc_get_symbol (gfc_get_string ("%s", "byte_stride"), sub_ns, &byte_stride);
   byte_stride->ts.type = BT_INTEGER;
   byte_stride->ts.kind = gfc_index_integer_kind;
   byte_stride->attr.flavor = FL_VARIABLE;
@@ -1656,7 +1656,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_commit_symbol (byte_stride);
 
   /* Set up formal argument.  */
-  gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+  gfc_get_symbol (gfc_get_string ("%s", "fini_coarray"), sub_ns, &fini_coarray);
   fini_coarray->ts.type = BT_LOGICAL;
   fini_coarray->ts.kind = 1;
   fini_coarray->attr.flavor = FL_VARIABLE;
@@ -1679,7 +1679,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
   /* Local variables.  */
 
-  gfc_get_symbol ("idx", sub_ns, &idx);
+  gfc_get_symbol (gfc_get_string ("%s", "idx"), sub_ns, &idx);
   idx->ts.type = BT_INTEGER;
   idx->ts.kind = gfc_index_integer_kind;
   idx->attr.flavor = FL_VARIABLE;
@@ -1687,7 +1687,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_set_sym_referenced (idx);
   gfc_commit_symbol (idx);
 
-  gfc_get_symbol ("idx2", sub_ns, &idx2);
+  gfc_get_symbol (gfc_get_string ("%s", "idx2"), sub_ns, &idx2);
   idx2->ts.type = BT_INTEGER;
   idx2->ts.kind = gfc_index_integer_kind;
   idx2->attr.flavor = FL_VARIABLE;
@@ -1695,7 +1695,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_set_sym_referenced (idx2);
   gfc_commit_symbol (idx2);
 
-  gfc_get_symbol ("offset", sub_ns, &offset);
+  gfc_get_symbol (gfc_get_string ("%s", "offset"), sub_ns, &offset);
   offset->ts.type = BT_INTEGER;
   offset->ts.kind = gfc_index_integer_kind;
   offset->attr.flavor = FL_VARIABLE;
@@ -1711,7 +1711,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
     gfc_convert_type_warn (rank, &idx->ts, 2, 0);
 
   /* Create is_contiguous variable.  */
-  gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
+  gfc_get_symbol (gfc_get_string ("%s", "is_contiguous"), sub_ns, &is_contiguous);
   is_contiguous->ts.type = BT_LOGICAL;
   is_contiguous->ts.kind = gfc_default_logical_kind;
   is_contiguous->attr.flavor = FL_VARIABLE;
@@ -1722,7 +1722,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   /* Create "sizes(0..rank)" variable, which contains the multiplied
      up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
      sizes(2) = sizes(1) * extent(dim=2) etc.  */
-  gfc_get_symbol ("sizes", sub_ns, &sizes);
+  gfc_get_symbol (gfc_get_string ("%s", "sizes"), sub_ns, &sizes);
   sizes->ts.type = BT_INTEGER;
   sizes->ts.kind = gfc_index_integer_kind;
   sizes->attr.flavor = FL_VARIABLE;
@@ -1739,7 +1739,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
   /* Create "strides(1..rank)" variable, which contains the strides per
      dimension.  */
-  gfc_get_symbol ("strides", sub_ns, &strides);
+  gfc_get_symbol (gfc_get_string ("%s", "strides"), sub_ns, &strides);
   strides->ts.type = BT_INTEGER;
   strides->ts.kind = gfc_index_integer_kind;
   strides->attr.flavor = FL_VARIABLE;
@@ -1919,7 +1919,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
   /* Obtain the size (number of elements) of "array" MINUS ONE,
      which is used in the scalarization.  */
-  gfc_get_symbol ("nelem", sub_ns, &nelem);
+  gfc_get_symbol (gfc_get_string ("%s", "nelem"), sub_ns, &nelem);
   nelem->ts.type = BT_INTEGER;
   nelem->ts.kind = gfc_index_integer_kind;
   nelem->attr.flavor = FL_VARIABLE;
@@ -1972,7 +1972,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
     {
       gfc_finalizer *fini, *fini_elem = NULL;
 
-      gfc_get_symbol ("ptr1", sub_ns, &ptr);
+      gfc_get_symbol (gfc_get_string ("%s", "ptr1"), sub_ns, &ptr);
       ptr->ts.type = BT_DERIVED;
       ptr->ts.u.derived = derived;
       ptr->attr.flavor = FL_VARIABLE;
@@ -2096,7 +2096,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
       if (!ptr)
 	{
-	  gfc_get_symbol ("ptr2", sub_ns, &ptr);
+	  gfc_get_symbol (gfc_get_string ("%s", "ptr2"), sub_ns, &ptr);
 	  ptr->ts.type = BT_DERIVED;
 	  ptr->ts.u.derived = derived;
 	  ptr->attr.flavor = FL_VARIABLE;
@@ -2106,7 +2106,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	  gfc_commit_symbol (ptr);
 	}
 
-      gfc_get_symbol ("ignore", sub_ns, &stat);
+      gfc_get_symbol (gfc_get_string ("%s", "ignore"), sub_ns, &stat);
       stat->attr.flavor = FL_VARIABLE;
       stat->attr.artificial = 1;
       stat->ts.type = BT_INTEGER;
@@ -2422,7 +2422,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		    copy->module = ns->proc_name->name;
 		  gfc_set_sym_referenced (copy);
 		  /* Set up formal arguments.  */
-		  gfc_get_symbol ("src", sub_ns, &src);
+		  gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
 		  src->ts.type = BT_DERIVED;
 		  src->ts.u.derived = derived;
 		  src->attr.flavor = FL_VARIABLE;
@@ -2432,7 +2432,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  gfc_set_sym_referenced (src);
 		  copy->formal = gfc_get_formal_arglist ();
 		  copy->formal->sym = src;
-		  gfc_get_symbol ("dst", sub_ns, &dst);
+		  gfc_get_symbol (gfc_get_string ("%s", "dst"), sub_ns, &dst);
 		  dst->ts.type = BT_DERIVED;
 		  dst->ts.u.derived = derived;
 		  dst->attr.flavor = FL_VARIABLE;
@@ -2497,7 +2497,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		    dealloc->module = ns->proc_name->name;
 		  gfc_set_sym_referenced (dealloc);
 		  /* Set up formal argument.  */
-		  gfc_get_symbol ("arg", sub_ns, &arg);
+		  gfc_get_symbol (gfc_get_string ("%s", "arg"), sub_ns, &arg);
 		  arg->ts.type = BT_DERIVED;
 		  arg->ts.u.derived = derived;
 		  arg->attr.flavor = FL_VARIABLE;
@@ -2759,7 +2759,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		copy->module = ns->proc_name->name;
 		  gfc_set_sym_referenced (copy);
 	      /* Set up formal arguments.  */
-	      gfc_get_symbol ("src", sub_ns, &src);
+	      gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
 	      src->ts.type = ts->type;
 	      src->ts.kind = ts->kind;
 	      src->attr.flavor = FL_VARIABLE;
@@ -2768,7 +2768,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      gfc_set_sym_referenced (src);
 	      copy->formal = gfc_get_formal_arglist ();
 	      copy->formal->sym = src;
-	      gfc_get_symbol ("dst", sub_ns, &dst);
+	      gfc_get_symbol (gfc_get_string ("%s", "dst"), sub_ns, &dst);
 	      dst->ts.type = ts->type;
 	      dst->ts.kind = ts->kind;
 	      dst->attr.flavor = FL_VARIABLE;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 55a59008f66..d6a6538f769 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2183,7 +2183,7 @@ gfc_match_null (gfc_expr **result)
     }
 
   /* The NULL symbol now has to be/become an intrinsic function.  */
-  if (gfc_get_symbol ("null", NULL, &sym))
+  if (gfc_get_symbol (gfc_get_string ("%s", "null"), NULL, &sym))
     {
       gfc_error ("NULL() initialization at %C is ambiguous");
       return MATCH_ERROR;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 389eead0691..755bff56e24 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -4442,10 +4442,10 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
   else
     {
       bool t;
-      char buffer[20];  /* Enough to hold "block@2147483648\n".  */
+      const char *block_name;
 
-      snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
-      gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
+      block_name = gfc_get_string ("block@%d", numblock++);
+      gfc_get_symbol (block_name, my_ns, &my_ns->proc_name);
       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
 			  my_ns->proc_name->name, NULL);
       gcc_assert (t);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e98e6a6d53e..88c16d462bd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -699,7 +699,7 @@ resolve_entries (gfc_namespace *ns)
   gfc_code *c;
   gfc_symbol *proc;
   gfc_entry_list *el;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  const char *name;
   static int master_count = 0;
 
   if (ns->proc_name == NULL)
@@ -758,8 +758,7 @@ resolve_entries (gfc_namespace *ns)
   /* Give the internal function a unique name (within this file).
      Also include the function name so the user has some hope of figuring
      out what is going on.  */
-  snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
-	    master_count++, ns->proc_name->name);
+  name = gfc_get_string ("master.%d.%s", master_count++, ns->proc_name->name);
   gfc_get_ha_symbol (name, &proc);
   gcc_assert (proc != NULL);
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ce134d2b441..53c760a6c38 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2975,10 +2975,10 @@ gfc_find_symtree (gfc_symtree *st, const char *name)
 gfc_symtree *
 gfc_get_unique_symtree (gfc_namespace *ns)
 {
-  char name[GFC_MAX_SYMBOL_LEN + 1];
   static int serial = 0;
+  const char *name;
 
-  sprintf (name, "@%d", serial++);
+  name = gfc_get_string ("@%d", serial++);
   return gfc_new_symtree (&ns->sym_root, name);
 }
 
-- 
2.19.0.rc1

Re: [PATCH,FORTRAN 09/29] Use stringpool for modules

[Janne Blomqvist]

On Wed, Sep 5, 2018 at 6:00 PM Bernhard Reutner-Fischer <
rep.dot.nop@gmail.com> wrote:

> diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
> index 38827ed4637..6596bd87c09 100644
> --- a/gcc/fortran/match.c
> +++ b/gcc/fortran/match.c
> @@ -1274,15 +1274,22 @@ not_yes:
>             case '%':
>               matches++;
>               break;            /* Skip.  */
> +#if 0
> +           /* If everybody is disciplined we do not need to reset this.
> */
> +           case 'n':
> +             vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't be */
> +             *vp = NULL;
> +             break;
> +#else
> +           case 'n':
> +#endif
>

Some debugging leftover that should be removed?

-- 
Janne Blomqvist

Re: [PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Janne Blomqvist]

On Wed, Sep 5, 2018 at 5:58 PM Bernhard Reutner-Fischer <
rep.dot.nop@gmail.com> wrote:

> Hi,
>
> The fortran frontend still uses stack-based handling of (symbol) names
> with fixed-sized buffers. Furthermore these buffers often are too small
> when dealing with F2003 identifiers which can be up to, including 63
> bytes long.
>
> Other frontends use the stringpool since many years.
> This janitorial series is a first step towards using the stringpool in
> the frontend.
> Consequently this allows us to use pointer-comparison to see if two
> given "names" are identical instead of doing lots and lots of string
> comparisons.
>
>
> Part 1 switches most of the fortran FE. An eventual part 2 would
> continue to switch the few remaining stack-based identifier
> manipulations to use the stringpool. My initial plan was to also see if
> switching gfc_symtree from treap to a hash_map would bring us any
> measurable benefit, but that, too, is left for an eventual part 2.
>
> Bootstrapped and regtested on x86_64-foo-linux.
>
> I'd appreciate if someone could double check for regressions on other
> setups. Git branch:
>
> https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
>
> Ok for trunk?
>

Hi,

this is quite an impressive patch set. I have looked through all the
patches, and on the surface they all look ok.

Unfortunately I don't have any exotic target to test on either, so I think
you just have to commit it and check for regression reports. Though I don't
see this set doing anything which would work differently on other targets,
but you never know..

I'd say wait a few days in case anybody else wants to comment on it, then
commit it to trunk.

Thanks for doing all this!


-- 
Janne Blomqvist

Re: [PATCH,FORTRAN 09/29] Use stringpool for modules

[Bernhard Reutner-Fischer]

On 5 September 2018 20:44:05 CEST, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>On Wed, Sep 5, 2018 at 6:00 PM Bernhard Reutner-Fischer <
>rep.dot.nop@gmail.com> wrote:
>
>> diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
>> index 38827ed4637..6596bd87c09 100644
>> --- a/gcc/fortran/match.c
>> +++ b/gcc/fortran/match.c
>> @@ -1274,15 +1274,22 @@ not_yes:
>>             case '%':
>>               matches++;
>>               break;            /* Skip.  */
>> +#if 0
>> +           /* If everybody is disciplined we do not need to reset
>this.
>> */
>> +           case 'n':
>> +             vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't
>be */
>> +             *vp = NULL;
>> +             break;
>> +#else
>> +           case 'n':
>> +#endif
>>
>
>Some debugging leftover that should be removed?

Well AFAIR this still blew up at some point. It's possible that this would work out fine now that all %n should be converted.
I'll have another look.

Re: [PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Bernhard Reutner-Fischer]

On Wed, 5 Sep 2018 at 20:57, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>
> On Wed, Sep 5, 2018 at 5:58 PM Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

>> Bootstrapped and regtested on x86_64-foo-linux.
>>
>> I'd appreciate if someone could double check for regressions on other
>> setups. Git branch:
>> https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
>>
>> Ok for trunk?
>
>
> Hi,
>
> this is quite an impressive patch set. I have looked through all the patches, and on the surface they all look ok.

Thanks alot for your appreciation!
>
> Unfortunately I don't have any exotic target to test on either, so I think you just have to commit it and check for regression reports. Though I don't see this set doing anything which would work differently on other targets, but you never know..
>
> I'd say wait a few days in case anybody else wants to comment on it, then commit it to trunk.

Upon further testing i encountered a regression in module writing,
manifesting itself in a failure to compile ieee_8.f90 (and only this).
f951: Fatal Error: Reading module ‘foo’ at line 4310 column 25: Expected string
where we write the following garbage:
366 ''''''''''''''''res'BLE IN UNKNOWN-PROC UNKNOWN UNKNOWN 0 0

End of last year when i wrote these patches i diffed each and every
module in my regtests and all these were identical, so it must be some
recent "regression" in that area.
Sorry for that, I'll have another look during the weekend.

thanks,

Re: [PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Bernhard Reutner-Fischer]

On Fri, 7 Sep 2018 at 10:07, Bernhard Reutner-Fischer
<rep.dot.nop@gmail.com> wrote:
>
> On Wed, 5 Sep 2018 at 20:57, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
> >
> > On Wed, Sep 5, 2018 at 5:58 PM Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>
> >> Bootstrapped and regtested on x86_64-foo-linux.
> >>
> >> I'd appreciate if someone could double check for regressions on other
> >> setups. Git branch:
> >> https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
> >>
> >> Ok for trunk?
> >
> >
> > Hi,
> >
> > this is quite an impressive patch set. I have looked through all the patches, and on the surface they all look ok.
>
> Thanks alot for your appreciation!
> >
> > Unfortunately I don't have any exotic target to test on either, so I think you just have to commit it and check for regression reports. Though I don't see this set doing anything which would work differently on other targets, but you never know..
> >
> > I'd say wait a few days in case anybody else wants to comment on it, then commit it to trunk.
>
> Upon further testing i encountered a regression in module writing,
> manifesting itself in a failure to compile ieee_8.f90 (and only this).

> Sorry for that, I'll have another look during the weekend.

so in free_pi_tree we should not free true_name nor module:

@@ -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);
 }

This fixes the module writing but leaks, obviously.
Now the reason why i initially did not use mio_pool_string for both
rsym.module and rsym.true_name was that mio_pool_string sets the name
to NULL if the string is empty.
Currently these are read by read_string() [which we should get rid of
entirely, the 2 mentioned fields are the last two who use
read_string()] which does not nullify the empty string but returns
just the pointer. For e.g. ieee_8.f90 using mio_pool_string gives us a
NULL module which leads to gfc_use_module -> load_needed ->
gfc_find_symbol -> gfc_find_sym_tree -> gfc_find_symtree which tries
to c = strcmp (name, st->name); where name is NULL.

The main culprits seem to be class finalization wrapper variables so
i'm adding modules to those now.
Which leaves me with regressions like allocate_with_source_14.f03.
"Fixing" these by falling back to gfc_current_ns->proc_name->name in
load_needed for !ns->proc_name if the rsym->module is NULL seems to
work.

Now there are a number of issues with names of fixups. Like the 9 in e.g.:

$ zcat /tmp/n/m.mod | egrep -v "^(\(\)|\(\(\)|$)"
GFORTRAN module version '15' created from generic_27.f90
(('testif' 'm' 2 3))
(4 'm' 'm' '' 1 ((MODULE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0)
3 'test1' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
0 FUNCTION) () (REAL 4 0 0 0 REAL ()) 5 0 (6) () 3 () () () 0 0)
2 'test2' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
0 FUNCTION ARRAY_OUTER_DEPENDENCY) () (REAL 4 0 0 0 REAL ()) 7 0 (8) ()
2 () () () 0 0)
6 'obj' '' '' 5 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0
0 DUMMY) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
8 'pr' '' '' 7 ((PROCEDURE UNKNOWN-INTENT DUMMY-PROC UNKNOWN UNKNOWN 0 0
EXTERNAL DUMMY FUNCTION PROCEDURE ARRAY_OUTER_DEPENDENCY) () (REAL 4 9 0
0 REAL ()) 0 0 () () 8 () () () 0 0)
9 '' '' '' 7 ((PROCEDURE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0
FUNCTION) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
)
('m' 0 4 'test1' 0 3 'test2' 0 2)

which is a bit of a complication since we need them to verify proper
interface types and attributes etc, etc.
generic_27.f90 would then warn in check_proc_interface() that
"Interface %qs at %L must be explicit".
To bypass this warning i suggest to flag these as artificial like so:
@@ -6679,10 +6683,12 @@ match_procedure_decl (void)
            return MATCH_ERROR;
          sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
          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;
        }

       if (gfc_match (" =>") == MATCH_YES)
@@ -6818,10 +6824,12 @@ match_ppc_decl (void)
          c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
          c->ts.interface->result = c->ts.interface;
          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;
        }

       if (gfc_match (" =>") == MATCH_YES)

and then not exclude ""-names but attr.artificial for the "must be
explicit" warning. This works fine.

Another spot where we encounter trouble with NULL module in the sym is
generic_1.f90 where we would be unable to distinguish interface sub
arguments during true_name lookup.
We find x in true names and consequently use this one sym for both the
REAL as well as the INTEGER variable which of course doesn't work when
resolving.
As it turns out we get away with punting true_name lookup if the module is NULL.

The next hintch are unlimited polymorphic component class containers
as in select_type_36.f03 when used in module context.
gfc_find_gsymbol() around the "upe" really wants a module that is
non-NULL which we luckily have at hand. This just extends the
proc_name-hack.

@@ -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;

The area of true_name and pi_root handling is a bit unpleasant to work
with, i must admit. But then i do not volunteer to rip it all out ;)
I think we will be able to remove some of these proc_name-hacks as
soon as we switch the symbol finding to pointer comparison, at least.

I'm cleaning up the above for a final test and will send it as
alternative, extended approach intended to replace the
"[PATCH,FORTRAN 25/29] Use stringpool on loading module symbols" (
https://gcc.gnu.org/ml/fortran/2018-09/msg00039.html )

patch, fwiw.

thanks,

[PATCH,FORTRAN v2] Use stringpool on loading module symbols

[Bernhard Reutner-Fischer]

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(-)

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;
-- 
2.19.0

Re: [PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Bernhard Reutner-Fischer]

On Fri, 7 Sep 2018 10:30:30 +0200
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> On Thu, 6 Sep 2018 at 03:25, Jerry DeLisle <jvdelisle@charter.net> wrote:
> >
> > On 09/05/2018 07:57 AM, Bernhard Reutner-Fischer wrote:  
> > > Hi,
> > >
> > > The fortran frontend still uses stack-based handling of (symbol) names
> > > with fixed-sized buffers. Furthermore these buffers often are too small
> > > when dealing with F2003 identifiers which can be up to, including 63
> > > bytes long.
> > >
> > > Other frontends use the stringpool since many years.
> > > This janitorial series is a first step towards using the stringpool in
> > > the frontend.
> > > Consequently this allows us to use pointer-comparison to see if two
> > > given "names" are identical instead of doing lots and lots of string
> > > comparisons.
> > >
> > >
> > > Part 1 switches most of the fortran FE. An eventual part 2 would
> > > continue to switch the few remaining stack-based identifier
> > > manipulations to use the stringpool. My initial plan was to also see if
> > > switching gfc_symtree from treap to a hash_map would bring us any
> > > measurable benefit, but that, too, is left for an eventual part 2.
> > >
> > > Bootstrapped and regtested on x86_64-foo-linux.
> > >
> > > I'd appreciate if someone could double check for regressions on other
> > > setups. Git branch:
> > > https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
> > >  
> >
> > I am not so git savvy as I would like. If you could send me a single
> > patch to trunk I will try to test on a FreeBSD system. It is usually a
> > bit more picky than linux..  
> 
> I've just encountered a regression in module writing, let me have a
> looksie at that first so i don't waste your time.
> 
> PS: You'd:
> git clone git://gcc.gnu.org/git/gcc.git ~/src/gcc-9.0-stringpool
> cd ~/src/gcc-9.0-stringpool
> git checkout aldot/fortran-fe-stringpool
> # this should output:
> # Branch aldot/fortran-fe-stringpool set up to track remote branch
> aldot/fortran-fe-stringpool from origin.
> # if your git client is too old, then do it manually:
> # git checkout -b aldot/fortran-fe-stringpool --track
> origin/aldot/fortran-fe-stringpool
> mkdir -p ~/obj/gcc-9.0-stringpool
> cd !$
> ../../src/gcc-9.0-stringpool/configure --prefix /opt/..... && make
> install && make -k check;# as usual
> 
> I'll send you a full patch when i had a chance to track down the
> module writing bug.

IIRC i fixed the abovementioned bug and pushed it to the branch.

Unfortunately the abovementioned personal git branch somehow was
deleted in the meantime.

Now i was about to rebase my local tree in the light of the upcoming
GCC-11 release and i'm confronted with a couple of conflicts that stem
from /me touching all these spots that are troublesome _and_ slow (due
to gazillions of strcmp calls to match identifiers; Part of the .plan
was to see if sacrificing a little bit of memory to maintain hash_map of
identifier_pointers would pay off WRT way faster comparison -- pointer
cmp versus strcmp as noted above. ISTR that's what other frontends do
since decades and i think it would make sense for the fortran FE too).

Iff there is any interest in eventually accepting abovementioned
direction into the tree, either part1 only which has merity on his
own - as you can see from recent asan induced tweaks to our identifier
handling - or also part 2 which encompasses the endavour to speedup the
actual matching of identifiers and hence speed up some small parts of
the frontend then i'm willing to rebase the series.

Of course if nobody thinks that the proposed direction is the right
thing to do then i will happily delete the effort so far. Saves quite
some of my sparetime.
For posteriority, a previous series of part1 was archived here:
https://gcc.gnu.org/pipermail/gcc-patches/2018-September/thread.html#506111

As can bee seen in the series and was in part explained in
https://gcc.gnu.org/pipermail/gcc-patches/2018-September/506849.html
this series changes module format a little bit. Specifically, several
spots do (or did back then, at least) use NULL module names in certain
situations in a non-obvious way (i wouldn't dare to say hackish for
i do not remember the gory details offhand i admit). I believe i
initially wrote the series even before submodules but AFAIR they did
not interfere in any noticable way. Modules were misbehaving but
submodules not, IIRC.

The fact that i need to change the module content was the main reason
why i did not apply the batch back then, even if Jerry was kind
enough to OK the submission as is, as you can see in above thread.
So i again reach out for consensus so to maybe get this improvement
into GCC-12 iff deemed appropriate and useful. Or i'll just drop it for
good.

thanks,

Re: [PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Bernhard Reutner-Fischer]

ping
[Rebased, re-regtested cleanly. Ok for trunk?]
On Wed,  5 Sep 2018 14:57:31 +0000
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
> 
> compiling gfortran.dg/typebound_proc_31.f90 leaked the type-bound
> structs:
> 
> 56 bytes in 1 blocks are definitely lost.
>   at 0x4C2CC05: calloc (vg_replace_malloc.c:711)
>   by 0x151EA90: xcalloc (xmalloc.c:162)
>   by 0x8E3E4F: gfc_get_typebound_proc(gfc_typebound_proc*) (symbol.c:4945)
>   by 0x84C095: match_procedure_in_type (decl.c:10486)
>   by 0x84C095: gfc_match_procedure() (decl.c:6696)
> ...
> 
> gcc/fortran/ChangeLog:
> 
> 2017-12-06  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* symbol.c (free_tb_tree): Free type-bound procedure struct.
> 	(gfc_get_typebound_proc): Use explicit memcpy for clarity.
> ---
>  gcc/fortran/symbol.c | 4 ++--
>  1 file changed, 2 insertions(+), 2 deletions(-)
> 
> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> index 53c760a6c38..cde34c67482 100644
> --- a/gcc/fortran/symbol.c
> +++ b/gcc/fortran/symbol.c
> @@ -3845,7 +3845,7 @@ free_tb_tree (gfc_symtree *t)
>  
>    /* TODO: Free type-bound procedure structs themselves; probably needs some
>       sort of ref-counting mechanism.  */
> -
> +  free (t->n.tb);
>    free (t);
>  }
>  
> @@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
>  
>    result = XCNEW (gfc_typebound_proc);
>    if (tb0)
> -    *result = *tb0;
> +    memcpy (result, tb0, sizeof (gfc_typebound_proc));;
>    result->error = 1;
>  
>    latest_undo_chgset->tbps.safe_push (result);

Re: [PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Jerry D]

Looks good and simple. Proceed. Thanks

Jerry

On 10/28/21 5:05 PM, Bernhard Reutner-Fischer via Fortran wrote:
> ping
> [Rebased, re-regtested cleanly. Ok for trunk?]
> On Wed,  5 Sep 2018 14:57:31 +0000
> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>
>> From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
>>
>> compiling gfortran.dg/typebound_proc_31.f90 leaked the type-bound
>> structs:
>>
>> 56 bytes in 1 blocks are definitely lost.
>>    at 0x4C2CC05: calloc (vg_replace_malloc.c:711)
>>    by 0x151EA90: xcalloc (xmalloc.c:162)
>>    by 0x8E3E4F: gfc_get_typebound_proc(gfc_typebound_proc*) (symbol.c:4945)
>>    by 0x84C095: match_procedure_in_type (decl.c:10486)
>>    by 0x84C095: gfc_match_procedure() (decl.c:6696)
>> ...
>>
>> gcc/fortran/ChangeLog:
>>
>> 2017-12-06  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>>
>> 	* symbol.c (free_tb_tree): Free type-bound procedure struct.
>> 	(gfc_get_typebound_proc): Use explicit memcpy for clarity.
>> ---
>>   gcc/fortran/symbol.c | 4 ++--
>>   1 file changed, 2 insertions(+), 2 deletions(-)
>>
>> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
>> index 53c760a6c38..cde34c67482 100644
>> --- a/gcc/fortran/symbol.c
>> +++ b/gcc/fortran/symbol.c
>> @@ -3845,7 +3845,7 @@ free_tb_tree (gfc_symtree *t)
>>   
>>     /* TODO: Free type-bound procedure structs themselves; probably needs some
>>        sort of ref-counting mechanism.  */
>> -
>> +  free (t->n.tb);
>>     free (t);
>>   }
>>   
>> @@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
>>   
>>     result = XCNEW (gfc_typebound_proc);
>>     if (tb0)
>> -    *result = *tb0;
>> +    memcpy (result, tb0, sizeof (gfc_typebound_proc));;
>>     result->error = 1;
>>   
>>     latest_undo_chgset->tbps.safe_push (result);

Re: [PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Bernhard Reutner-Fischer]

On Fri, 29 Oct 2021 07:54:21 -0700
Jerry D <jvdelisle2@gmail.com> wrote:

> Looks good and simple. Proceed. Thanks

Committed as 7883a7f07c1ad9c8aaccc5bbd96e0ae1fa230c89
Thanks!

Maybe somebody could eyeball and ACK "Fix memory leak in finalization
wrappers"
https://gcc.gnu.org/pipermail/fortran/2021-October/056838.html

We were generating (and emitting to modules) finalization wrapper
needlessly, i.e. even when they were not called for.

This 1) leaked like shown in the initial submission and
2) polluted module files with unwarranted (wrong) mention of
finalization wrappers even when compiling without any coarray stuff.

E.g. a modified udr10.f90 (from libgomp) has the following diff in the
module which illustrates the positive side-effect of the fix:

-26 'array' '' '' 25 ((VARIABLE INOUT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0
-ARTIFICIAL DIMENSION CONTIGUOUS DUMMY) () (DERIVED 3 0 0 0 DERIVED ()) 0
-0 () (0 0 ASSUMED_RANK) 0 () () () 0 0)
-27 'byte_stride' '' '' 25 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN
-UNKNOWN 0 0 ARTIFICIAL VALUE DUMMY) () (INTEGER 8 0 0 0 INTEGER ()) 0 0
-() () 0 () () () 0 0)
-28 'fini_coarray' '' '' 25 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC
-UNKNOWN UNKNOWN 0 0 ARTIFICIAL VALUE DUMMY) () (LOGICAL 1 0 0 0 LOGICAL
-()) 0 0 () () 0 () () () 0 0)

thanks,

Re: [PATCH,FORTRAN 01/29] gdbinit: break on gfc_internal_error

[Bernhard Reutner-Fischer]

ping

On Wed,  5 Sep 2018 14:57:04 +0000
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
> 
> Aids debugging the fortran FE.
> 
> gcc/ChangeLog:
> 
> 2017-11-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* gdbinit.in: Break on gfc_internal_error.
> ---
>  gcc/gdbinit.in | 1 +
>  1 file changed, 1 insertion(+)
> 
> diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
> index 4db977f0bab..ac4d7c42e21 100644
> --- a/gcc/gdbinit.in
> +++ b/gcc/gdbinit.in
> @@ -227,6 +227,7 @@ b fancy_abort
>  
>  # Put a breakpoint on internal_error to help with debugging ICEs.
>  b internal_error
> +b gfc_internal_error
>  
>  set complaints 0
>  # Don't let abort actually run, as it will make

Re: [PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Bernhard Reutner-Fischer]

On Fri, 29 Oct 2021 21:36:26 +0200
Harald Anlauf via Gcc-patches <gcc-patches@gcc.gnu.org> wrote:

> Dear Bernhard, all,
> 
> Am 29.10.21 um 02:05 schrieb Bernhard Reutner-Fischer via Gcc-patches:
> 
> >> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> >> index 53c760a6c38..cde34c67482 100644
> >> --- a/gcc/fortran/symbol.c
> >> +++ b/gcc/fortran/symbol.c  
> 
> >> @@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
> >>   
> >>     result = XCNEW (gfc_typebound_proc);
> >>     if (tb0)
> >> -    *result = *tb0;
> >> +    memcpy (result, tb0, sizeof (gfc_typebound_proc));;
> >>     result->error = 1;
> >>   
> >>     latest_undo_chgset->tbps.safe_push (result);  
> > 
> >   
> 
> please forgive me, but frankly speaking, I don't like this change.
> 
> It seems to serve no obvious purpose other than obfuscating the code
> and defeating the compiler's ability to detect type mismatches.

mhm okay.
IIRC these are folded to memcpy early on and in some projects with
certain optimization levels results in an unobvious call to memcpy
(which poses trouble if you want to avoid relocations at all cost which
this might trigger if pulling in memcpy unexpectedly).
f951 of course is not in the camp to bother much about this so i admit
the change might stem from a tinfoil-hat moment of mine and might not
be appropriate here.

Although i don't buy the argument of the possibility of papering over
type-mismatches in this particular case (the incoming arg is typed
gfc_typebound_proc*, the result is typed gfc_typebound_proc*, the
allocation is casted to gfc_typebound_proc*) we can certainly revert
that hunk if folks prefer.

> 
> I would not have OKed that part of the patch.

For reference:
gcc/fortran/symbol.c
gfc_typebound_proc*
gfc_get_typebound_proc (gfc_typebound_proc *tb0)
{
  gfc_typebound_proc *result;

  result = XCNEW (gfc_typebound_proc);
  if (tb0)
    memcpy (result, tb0, sizeof (gfc_typebound_proc));
  result->error = 1;

  latest_undo_chgset->tbps.safe_push (result);

  return result;
}

And i did
-    *result = *tb0;
+    memcpy (result, tb0, sizeof (gfc_typebound_proc));

> 
> Harald
> 

Re: [PATCH,FORTRAN 01/29] gdbinit: break on gfc_internal_error

[Jerry D]

Looks OK.

Cheers

On 10/29/21 11:58 AM, Bernhard Reutner-Fischer via Fortran wrote:
> ping
>
> On Wed,  5 Sep 2018 14:57:04 +0000
> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>
>> From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
>>
>> Aids debugging the fortran FE.
>>
>> gcc/ChangeLog:
>>
>> 2017-11-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>>
>> 	* gdbinit.in: Break on gfc_internal_error.
>> ---
>>   gcc/gdbinit.in | 1 +
>>   1 file changed, 1 insertion(+)
>>
>> diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
>> index 4db977f0bab..ac4d7c42e21 100644
>> --- a/gcc/gdbinit.in
>> +++ b/gcc/gdbinit.in
>> @@ -227,6 +227,7 @@ b fancy_abort
>>   
>>   # Put a breakpoint on internal_error to help with debugging ICEs.
>>   b internal_error
>> +b gfc_internal_error
>>   
>>   set complaints 0
>>   # Don't let abort actually run, as it will make

Re: [PATCH,FORTRAN 01/29] gdbinit: break on gfc_internal_error

[Bernhard Reutner-Fischer]

On 30 October 2021 00:13:06 CEST, Jerry D <jvdelisle2@gmail.com> wrote:
>Looks OK.

Thanks!
I guess I need an OK from some global maintainer, too?

The breakpoint is ignored by automatically answering the question with n if the symbol is not found when loading .gdbinit for e.g. cc1.

thanks,
>
>Cheers
>
>On 10/29/21 11:58 AM, Bernhard Reutner-Fischer via Fortran wrote:
>> ping
>>
>> On Wed,  5 Sep 2018 14:57:04 +0000
>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>
>>> From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org>
>>>
>>> Aids debugging the fortran FE.
>>>
>>> gcc/ChangeLog:
>>>
>>> 2017-11-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
>>>
>>> 	* gdbinit.in: Break on gfc_internal_error.
>>> ---
>>>   gcc/gdbinit.in | 1 +
>>>   1 file changed, 1 insertion(+)
>>>
>>> diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
>>> index 4db977f0bab..ac4d7c42e21 100644
>>> --- a/gcc/gdbinit.in
>>> +++ b/gcc/gdbinit.in
>>> @@ -227,6 +227,7 @@ b fancy_abort
>>>   
>>>   # Put a breakpoint on internal_error to help with debugging ICEs.
>>>   b internal_error
>>> +b gfc_internal_error
>>>   
>>>   set complaints 0
>>>   # Don't let abort actually run, as it will make
>

Re: [PATCH,FORTRAN 28/29] Free type-bound procedure structs

[Bernhard Reutner-Fischer]

On Fri, 29 Oct 2021 22:09:07 +0200
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> On Fri, 29 Oct 2021 21:36:26 +0200
> Harald Anlauf via Gcc-patches <gcc-patches@gcc.gnu.org> wrote:
> 
> > Dear Bernhard, all,
> > 
> > Am 29.10.21 um 02:05 schrieb Bernhard Reutner-Fischer via Gcc-patches:
> >   
> > >> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> > >> index 53c760a6c38..cde34c67482 100644
> > >> --- a/gcc/fortran/symbol.c
> > >> +++ b/gcc/fortran/symbol.c    
> >   
> > >> @@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
> > >>   
> > >>     result = XCNEW (gfc_typebound_proc);
> > >>     if (tb0)
> > >> -    *result = *tb0;
> > >> +    memcpy (result, tb0, sizeof (gfc_typebound_proc));;
> > >>     result->error = 1;
> > >>   
> > >>     latest_undo_chgset->tbps.safe_push (result);    
> > > 
> > >     
> > 
> > please forgive me, but frankly speaking, I don't like this change.
> > 
> > It seems to serve no obvious purpose other than obfuscating the code
> > and defeating the compiler's ability to detect type mismatches.  
> 
> mhm okay.
> > 
> > I would not have OKed that part of the patch.  

I reverted this hunk.
thanks,

Re: [PATCH,FORTRAN 00/29] Move towards stringpool, part 1

[Bernhard Reutner-Fischer]

Hi all, Janne!

On Wed, 19 Sep 2018 16:40:01 +0200
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> On Fri, 7 Sep 2018 at 10:07, Bernhard Reutner-Fischer
> <rep.dot.nop@gmail.com> wrote:
> >
> > On Wed, 5 Sep 2018 at 20:57, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:  
> > >
> > > On Wed, Sep 5, 2018 at 5:58 PM Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:  
> >  
> > >> Bootstrapped and regtested on x86_64-foo-linux.
> > >>
> > >> I'd appreciate if someone could double check for regressions on other
> > >> setups. Git branch:
> > >> https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
> > >>
> > >> Ok for trunk?  
> > >
> > >
> > > Hi,
> > >
> > > this is quite an impressive patch set. I have looked through all the patches, and on the surface they all look ok.  
> >
> > Thanks alot for your appreciation!  
> > >
> > > Unfortunately I don't have any exotic target to test on either, so I think you just have to commit it and check for regression reports. Though I don't see this set doing anything which would work differently on other targets, but you never know..
> > >
> > > I'd say wait a few days in case anybody else wants to comment on it, then commit it to trunk.  

Unfortunately I never got to commit it.

Are you still OK with this series?

Iff so, i will refresh it for gcc-14 stage1. I would formally resubmit
the series for approval then, of course, for good measure.

It will need some small adjustments since coarrays were added
afterwards and a few other spots were changed since then.

Note that after your OK i fixed the problem described below with this
patch
https://inbox.sourceware.org/gcc-patches/20180919225533.20009-1-rep.dot.nop@gmail.com/
and so i think this "[PATCH,FORTRAN v2] Use stringpool on loading
module symbols" was not formally OKed yet, FWIW. I believe that this v2 worked flawlessly.
Note, however, that by adding/changing module names of symbols in the
module files, this will (i think / fear) require a bump of the module
version if we are honest. Ultimately that was the reason why i did not
push the series back then.

Link to the old series:
https://inbox.sourceware.org/gcc-patches/20180905145732.404-1-rep.dot.nop@gmail.com/

thanks and cheers,

> >
> > Upon further testing i encountered a regression in module writing,
> > manifesting itself in a failure to compile ieee_8.f90 (and only this).  
> 
> > Sorry for that, I'll have another look during the weekend.  
> 
> so in free_pi_tree we should not free true_name nor module:
> 
> @@ -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);
>  }
> 
> This fixes the module writing but leaks, obviously.
> Now the reason why i initially did not use mio_pool_string for both
> rsym.module and rsym.true_name was that mio_pool_string sets the name
> to NULL if the string is empty.
> Currently these are read by read_string() [which we should get rid of
> entirely, the 2 mentioned fields are the last two who use
> read_string()] which does not nullify the empty string but returns
> just the pointer. For e.g. ieee_8.f90 using mio_pool_string gives us a
> NULL module which leads to gfc_use_module -> load_needed ->
> gfc_find_symbol -> gfc_find_sym_tree -> gfc_find_symtree which tries
> to c = strcmp (name, st->name); where name is NULL.
> 
> The main culprits seem to be class finalization wrapper variables so
> i'm adding modules to those now.
> Which leaves me with regressions like allocate_with_source_14.f03.
> "Fixing" these by falling back to gfc_current_ns->proc_name->name in
> load_needed for !ns->proc_name if the rsym->module is NULL seems to
> work.
> 
> Now there are a number of issues with names of fixups. Like the 9 in e.g.:
> 
> $ zcat /tmp/n/m.mod | egrep -v "^(\(\)|\(\(\)|$)"
> GFORTRAN module version '15' created from generic_27.f90
> (('testif' 'm' 2 3))
> (4 'm' 'm' '' 1 ((MODULE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0)
> 3 'test1' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
> 0 FUNCTION) () (REAL 4 0 0 0 REAL ()) 5 0 (6) () 3 () () () 0 0)
> 2 'test2' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
> 0 FUNCTION ARRAY_OUTER_DEPENDENCY) () (REAL 4 0 0 0 REAL ()) 7 0 (8) ()
> 2 () () () 0 0)
> 6 'obj' '' '' 5 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0
> 0 DUMMY) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
> 8 'pr' '' '' 7 ((PROCEDURE UNKNOWN-INTENT DUMMY-PROC UNKNOWN UNKNOWN 0 0
> EXTERNAL DUMMY FUNCTION PROCEDURE ARRAY_OUTER_DEPENDENCY) () (REAL 4 9 0
> 0 REAL ()) 0 0 () () 8 () () () 0 0)
> 9 '' '' '' 7 ((PROCEDURE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0
> FUNCTION) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
> )
> ('m' 0 4 'test1' 0 3 'test2' 0 2)
> 
> which is a bit of a complication since we need them to verify proper
> interface types and attributes etc, etc.
> generic_27.f90 would then warn in check_proc_interface() that
> "Interface %qs at %L must be explicit".
> To bypass this warning i suggest to flag these as artificial like so:
> @@ -6679,10 +6683,12 @@ match_procedure_decl (void)
>             return MATCH_ERROR;
>           sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
>           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;
>         }
> 
>        if (gfc_match (" =>") == MATCH_YES)
> @@ -6818,10 +6824,12 @@ match_ppc_decl (void)
>           c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
>           c->ts.interface->result = c->ts.interface;
>           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;
>         }
> 
>        if (gfc_match (" =>") == MATCH_YES)
> 
> and then not exclude ""-names but attr.artificial for the "must be
> explicit" warning. This works fine.
> 
> Another spot where we encounter trouble with NULL module in the sym is
> generic_1.f90 where we would be unable to distinguish interface sub
> arguments during true_name lookup.
> We find x in true names and consequently use this one sym for both the
> REAL as well as the INTEGER variable which of course doesn't work when
> resolving.
> As it turns out we get away with punting true_name lookup if the module is NULL.
> 
> The next hintch are unlimited polymorphic component class containers
> as in select_type_36.f03 when used in module context.
> gfc_find_gsymbol() around the "upe" really wants a module that is
> non-NULL which we luckily have at hand. This just extends the
> proc_name-hack.
> 
> @@ -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;
> 
> The area of true_name and pi_root handling is a bit unpleasant to work
> with, i must admit. But then i do not volunteer to rip it all out ;)
> I think we will be able to remove some of these proc_name-hacks as
> soon as we switch the symbol finding to pointer comparison, at least.
> 
> I'm cleaning up the above for a final test and will send it as
> alternative, extended approach intended to replace the
> "[PATCH,FORTRAN 25/29] Use stringpool on loading module symbols" (
> https://gcc.gnu.org/ml/fortran/2018-09/msg00039.html )
> 
> patch, fwiw.
> 
> thanks,