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

[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

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

[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 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

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 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.

[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 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 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 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 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

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 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,

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,

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,

[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 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

[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 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 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 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 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 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 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 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 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 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 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 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 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

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 28/29] Free type-bound procedure structs

[Harald Anlauf]

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.

I would not have OKed that part of the patch.

Harald

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 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,

[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

[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 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 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 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 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