re PR fortran/44265 (Link error with reference to parameter array in specification expression)

2016-12-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/44265
	* gfortran.h : Add fn_result_spec bitfield to gfc_symbol.
	* resolve.c (flag_fn_result_spec): New function.
	(resolve_fntype): Call it for character result lengths.
	* symbol.c (gfc_new_symbol): Set fn_result_spec to zero.
	* trans-decl.c (gfc_sym_mangled_identifier): Include the
	procedure name in the mangled name for symbols with the
	fn_result_spec bit set.
	(gfc_finish_var_decl): Mark the decls of these symbols
	appropriately for the case where the function is external.
	(gfc_get_symbol_decl): Mangle the name of these symbols.
	(gfc_create_module_variable): Allow them through the assert.
	(gfc_generate_function_code): Remove the assert before the
	initialization of sym->tlink because the frontend no longer
	uses this field.
	* trans-expr.c (gfc_map_intrinsic_function): Add a case to
	treat the LEN_TRIM intrinsic.
	(gfc_trans_string_copy): Deal with Wstringop-overflow warning
	that can occur with constant source lengths at -O3.

2016-12-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/44265
	* gfortran.dg/char_result_14.f90: New test.
	* gfortran.dg/char_result_15.f90: New test.

From-SVN: r243478

6 files changed, 150 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index eb5e987..b27c1e3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2016-12-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/44265
+	* gfortran.h : Add fn_result_spec bitfield to gfc_symbol.
+	* resolve.c (flag_fn_result_spec): New function.
+	(resolve_fntype): Call it for character result lengths.
+	* symbol.c (gfc_new_symbol): Set fn_result_spec to zero.
+	* trans-decl.c (gfc_sym_mangled_identifier): Include the
+	procedure name in the mangled name for symbols with the
+	fn_result_spec bit set.
+	(gfc_finish_var_decl): Mark the decls of these symbols
+	appropriately for the case where the function is external.
+	(gfc_get_symbol_decl): Mangle the name of these symbols.
+	(gfc_create_module_variable): Allow them through the assert.
+	(gfc_generate_function_code): Remove the assert before the
+	initialization of sym->tlink because the frontend no longer
+	uses this field.
+	* trans-expr.c (gfc_map_intrinsic_function): Add a case to
+	treat the LEN_TRIM intrinsic.
+	(gfc_trans_string_copy): Deal with Wstringop-overflow warning
+	that can occur with constant source lengths at -O3.
+
 2016-12-08  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/65173
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fcd3a3f..670c13a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1545,6 +1545,8 @@ typedef struct gfc_symbol
   unsigned equiv_built:1;
   /* Set if this variable is used as an index name in a FORALL.  */
   unsigned forall_index:1;
+  /* Set if the symbol is used in a function result specification .  */
+  unsigned fn_result_spec:1;
   /* Used to avoid multiple resolutions of a single symbol.  */
   unsigned resolved:1;
   /* Set if this is a module function or subroutine with the
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e4ea10f..2093de9 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -566,6 +566,14 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
 {
   bool t;
 
+  if (sym && sym->attr.flavor == FL_PROCEDURE
+      && 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))
+    gfc_error ("Contained procedure %qs at %L has the same name as its "
+	       "encompassing procedure", sym->name, &sym->declared_at);
+
   /* If this namespace is not a function or an entry master function,
      ignore it.  */
   if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
@@ -15747,6 +15755,54 @@ resolve_equivalence (gfc_equiv *eq)
 }
 
 
+/* Function called by resolve_fntype to flag other symbol used in the
+   length type parameter specification of function resuls.  */
+
+static bool
+flag_fn_result_spec (gfc_expr *expr,
+                     gfc_symbol *sym ATTRIBUTE_UNUSED,
+                     int *f ATTRIBUTE_UNUSED)
+{
+  gfc_namespace *ns;
+  gfc_symbol *s;
+
+  if (expr->expr_type == EXPR_VARIABLE)
+    {
+      s = expr->symtree->n.sym;
+      for (ns = s->ns; ns; ns = ns->parent)
+	if (!ns->parent)
+	  break;
+
+      if (!s->fn_result_spec
+	  && s->attr.flavor == FL_PARAMETER)
+	{
+	  /* Function contained in a module.... */
+	  if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
+	    {
+	      gfc_symtree *st;
+	      s->fn_result_spec = 1;
+	      /* Make sure that this symbol is translated as a module
+		 variable.  */
+	      st = gfc_get_unique_symtree (ns);
+	      st->n.sym = s;
+	      s->refs++;
+	    }
+	  /* ... which is use associated and called.  */
+	  else if (s->attr.use_assoc || s->attr.used_in_submodule
+			||
+		  /* External function matched with an interface.  */
+		  (s->ns->proc_name
+		   && ((s->ns == ns
+			 && s->ns->proc_name->attr.if_source == IFSRC_DECL)
+		       || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
+		   && s->ns->proc_name->attr.function))
+	    s->fn_result_spec = 1;
+	}
+    }
+  return false;
+}
+
+
 /* Resolve function and ENTRY types, issue diagnostics if needed.  */
 
 static void
@@ -15797,6 +15853,9 @@ resolve_fntype (gfc_namespace *ns)
 	    el->sym->attr.untyped = 1;
 	  }
       }
+
+  if (sym->ts.type == BT_CHARACTER)
+    gfc_traverse_expr (sym->ts.u.cl->length, NULL, flag_fn_result_spec, 0);
 }
 
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 882be92..f16e626 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2965,6 +2965,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   p->common_block = NULL;
   p->f2k_derived = NULL;
   p->assoc = NULL;
+  p->fn_result_spec = 0;
   
   return p;
 }
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2e6ef2a..f659a48 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -356,12 +356,36 @@ gfc_sym_mangled_identifier (gfc_symbol * sym)
   if (sym->attr.is_bind_c == 1 && sym->binding_label)
     return get_identifier (sym->binding_label);
 
-  if (sym->module == NULL)
-    return gfc_sym_identifier (sym);
+  if (!sym->fn_result_spec)
+    {
+      if (sym->module == NULL)
+	return gfc_sym_identifier (sym);
+      else
+	{
+	  snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
+	  return get_identifier (name);
+	}
+    }
   else
     {
-      snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
-      return get_identifier (name);
+      /* This is an entity that is actually local to a module procedure
+	 that appears in the result specification expression.  Since
+	 sym->module will be a zero length string, we use ns->proc_name
+	 instead. */
+      if (sym->ns->proc_name && sym->ns->proc_name->module)
+	{
+	  snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s",
+		    sym->ns->proc_name->module,
+		    sym->ns->proc_name->name,
+		    sym->name);
+	  return get_identifier (name);
+	}
+      else
+	{
+	  snprintf (name, sizeof name, "__%s_PROC_%s",
+		    sym->ns->proc_name->name, sym->name);
+	  return get_identifier (name);
+	}
     }
 }
 
@@ -615,6 +639,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
       DECL_EXTERNAL (decl) = 1;
       TREE_PUBLIC (decl) = 1;
     }
+  else if (sym->fn_result_spec && !sym->ns->proc_name->module)
+    {
+
+      if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
+	DECL_EXTERNAL (decl) = 1;
+      else
+	TREE_STATIC (decl) = 1;
+
+      TREE_PUBLIC (decl) = 1;
+    }
   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
     {
       /* TODO: Don't set sym->module for result or dummy variables.  */
@@ -1632,7 +1666,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   /* Create string length decl first so that they can be used in the
      type declaration.  For associate names, the target character
      length is used. Set 'length' to a constant so that if the
-     string lenght is a variable, it is not finished a second time.  */
+     string length is a variable, it is not finished a second time.  */
   if (sym->ts.type == BT_CHARACTER)
     {
       if (sym->attr.associate_var
@@ -1654,7 +1688,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   /* Symbols from modules should have their assembler names mangled.
      This is done here rather than in gfc_finish_var_decl because it
      is different for string length variables.  */
-  if (sym->module)
+  if (sym->module || sym->fn_result_spec)
     {
       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
       if (sym->attr.use_assoc && !intrinsic_array_parameter)
@@ -4766,7 +4800,9 @@ gfc_create_module_variable (gfc_symbol * sym)
 
   /* Create the variable.  */
   pushdecl (decl);
-  gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+  gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
+	      || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
+		  && sym->fn_result_spec));
   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
   rest_of_decl_compilation (decl, 1, 0);
   gfc_module_add_decl (cur_module, decl);
@@ -6153,8 +6189,8 @@ gfc_generate_function_code (gfc_namespace * ns)
   previous_procedure_symbol = current_procedure_symbol;
   current_procedure_symbol = sym;
 
-  /* Check that the frontend isn't still using this.  */
-  gcc_assert (sym->tlink == NULL);
+  /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
+     lost or worse.  */
   sym->tlink = sym;
 
   /* Create the declaration for functions with global scope.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 78bff87..8cb0f1c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4116,6 +4116,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
       new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
       break;
 
+    case GFC_ISYM_LEN_TRIM:
+      new_expr = gfc_copy_expr (arg1);
+      gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+
+      if (!new_expr)
+	return false;
+
+      gfc_replace_expr (arg1, new_expr);
+      return true;
+
     case GFC_ISYM_SIZE:
       if (!sym->as || sym->as->rank == 0)
 	return false;
@@ -6484,10 +6494,18 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
 			      builtin_decl_explicit (BUILT_IN_MEMMOVE),
 			      3, dest, src, slen);
 
+  /* Wstringop-overflow appears at -O3 even though this warning is not
+     explicitly available in fortran nor can it be switched off. If the
+     source length is a constant, its negative appears as a very large
+     postive number and triggers the warning in BUILTIN_MEMSET. Fixing
+     the result of the MINUS_EXPR suppresses this spurious warning.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			 TREE_TYPE(dlen), dlen, slen);
+  if (slength && TREE_CONSTANT (slength))
+    tmp = gfc_evaluate_now (tmp, block);
+
   tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
-  tmp4 = fill_with_spaces (tmp4, chartype,
-			   fold_build2_loc (input_location, MINUS_EXPR,
-					    TREE_TYPE(dlen), dlen, slen));
+  tmp4 = fill_with_spaces (tmp4, chartype, tmp);
 
   gfc_init_block (&tempblock);
   gfc_add_expr_to_block (&tempblock, tmp3);