backport: trans-decl.c (create_function_arglist): Handle dummy functions.

	Backport from gomp-20050608-branch
	* trans-decl.c (create_function_arglist): Handle dummy functions.

	* trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
	TYPE_SIZE_UNIT.
	(gfc_trans_vla_type_sizes): Also "gimplify"
	GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
	* trans-array.c (gfc_trans_deferred_array): Call
	gfc_trans_vla_type_sizes.

	* trans-decl.c (saved_function_decls, saved_parent_function_decls):
	Remove unnecessary initialization.
	(create_function_arglist): Make sure __result has complete type.
	(gfc_get_fake_result_decl): Change current_fake_result_decl into
	a tree chain.  For entry master, create a separate variable
	for each result name.  For BT_CHARACTER results, call
	gfc_finish_var_decl on length even if it has been already created,
	but not pushdecl'ed.
	(gfc_trans_vla_type_sizes): For function/entry result, adjust
	result value type, not the FUNCTION_TYPE.
	(gfc_generate_function_code): Adjust for current_fake_result_decl
	changes.
	(gfc_trans_deferred_vars): Likewise.  Call gfc_trans_vla_type_sizes
	even on result if it is assumed-length character.

	* trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
	Call gfc_trans_vla_type_sizes.
	(gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
	(gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
	gfc_trans_vla_type_sizes): New functions.
	(gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
	callers.  Call gfc_trans_vla_type_sizes on assumed-length
	character parameters.
	* trans-array.c (gfc_trans_array_bounds,
	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
	gfc_trans_vla_type_sizes.
	* trans.h (gfc_trans_vla_type_sizes): New prototype.

	* trans-decl.c (gfc_build_qualified_array): For non-assumed-size
	arrays without constant size, create also an index var for
	GFC_TYPE_ARRAY_SIZE (type).  If the type is incomplete, complete
	it as 0..size-1.
	(gfc_create_string_length): Don't call gfc_defer_symbol_init
	if just creating DECL_ARGUMENTS.
	(gfc_get_symbol_decl): Call gfc_finish_var_decl and
	gfc_defer_symbol_init even if ts.cl->backend_decl is already
	set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
	(create_function_arglist): Rework, so that hidden length
	arguments for CHARACTER parameters are created together with
	the parameters.  Resolve ts.cl->backend_decl for CHARACTER
	parameters.  If the argument is a non-constant length array
	or CHARACTER, ensure PARM_DECL has different type than
	its DECL_ARG_TYPE.
	(generate_local_decl): Call gfc_get_symbol_decl even
	for non-referenced non-constant length CHARACTER parameters
	after optionally issuing warnings.
	* trans-array.c (gfc_trans_array_bounds): Set last stride
	to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
	(gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
	variable as well.

	* trans-expr.c (gfc_conv_expr_val): Fix comment typo.

	* trans-stmt.c (gfc_trans_simple_do): Fix comment.

From-SVN: r110653

gcc/fortran/ChangeLog

+2006-02-06  Jakub Jelinek  <jakub@redhat.com>
+
+	Backport from gomp-20050608-branch
+	* trans-decl.c (create_function_arglist): Handle dummy functions.
+
+	* trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
+	TYPE_SIZE_UNIT.
+	(gfc_trans_vla_type_sizes): Also "gimplify"
+	GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
+	* trans-array.c (gfc_trans_deferred_array): Call
+	gfc_trans_vla_type_sizes.
+
+	* trans-decl.c (saved_function_decls, saved_parent_function_decls):
+	Remove unnecessary initialization.
+	(create_function_arglist): Make sure __result has complete type.
+	(gfc_get_fake_result_decl): Change current_fake_result_decl into
+	a tree chain.  For entry master, create a separate variable
+	for each result name.  For BT_CHARACTER results, call
+	gfc_finish_var_decl on length even if it has been already created,
+	but not pushdecl'ed.
+	(gfc_trans_vla_type_sizes): For function/entry result, adjust
+	result value type, not the FUNCTION_TYPE.
+	(gfc_generate_function_code): Adjust for current_fake_result_decl
+	changes.
+	(gfc_trans_deferred_vars): Likewise.  Call gfc_trans_vla_type_sizes
+	even on result if it is assumed-length character.
+
+	* trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
+	Call gfc_trans_vla_type_sizes.
+	(gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
+	(gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
+	gfc_trans_vla_type_sizes): New functions.
+	(gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
+	callers.  Call gfc_trans_vla_type_sizes on assumed-length
+	character parameters.
+	* trans-array.c (gfc_trans_array_bounds,
+	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
+	gfc_trans_vla_type_sizes.
+	* trans.h (gfc_trans_vla_type_sizes): New prototype.
+
+	* trans-decl.c (gfc_build_qualified_array): For non-assumed-size
+	arrays without constant size, create also an index var for
+	GFC_TYPE_ARRAY_SIZE (type).  If the type is incomplete, complete
+	it as 0..size-1.
+	(gfc_create_string_length): Don't call gfc_defer_symbol_init
+	if just creating DECL_ARGUMENTS.
+	(gfc_get_symbol_decl): Call gfc_finish_var_decl and
+	gfc_defer_symbol_init even if ts.cl->backend_decl is already
+	set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
+	(create_function_arglist): Rework, so that hidden length
+	arguments for CHARACTER parameters are created together with
+	the parameters.  Resolve ts.cl->backend_decl for CHARACTER
+	parameters.  If the argument is a non-constant length array
+	or CHARACTER, ensure PARM_DECL has different type than
+	its DECL_ARG_TYPE.
+	(generate_local_decl): Call gfc_get_symbol_decl even
+	for non-referenced non-constant length CHARACTER parameters
+	after optionally issuing warnings.
+	* trans-array.c (gfc_trans_array_bounds): Set last stride
+	to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
+	(gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
+	variable as well.
+
+	* trans-expr.c (gfc_conv_expr_val): Fix comment typo.
+
+	* trans-stmt.c (gfc_trans_simple_do): Fix comment.
+
 2006-02-04  Roger Sayle  <roger@eyesopen.com>
 
 	* dependency.c (gfc_check_dependency): Remove unused vars and nvars

gcc/fortran/trans-array.c

@@ -3255,7 +3255,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
       if (dim + 1 < as->rank)
         stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
       else
-        stride = NULL_TREE;
+	stride = GFC_TYPE_ARRAY_SIZE (type);
 
       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
         {
@@ -3273,6 +3273,8 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
       size = stride;
     }
 
+  gfc_trans_vla_type_sizes (sym, pblock);
+
   *poffset = offset;
   return size;
 }
@@ -3309,6 +3311,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
     {
       gfc_trans_init_string_length (sym->ts.cl, &block);
 
+      gfc_trans_vla_type_sizes (sym, &block);
+
       /* Emit a DECL_EXPR for this variable, which will cause the
 	 gimplifier to allocate storage, and all that good stuff.  */
       tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
@@ -3661,12 +3665,30 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
               gfc_add_modify_expr (&block, stride, tmp);
             }
         }
+      else
+	{
+	  stride = GFC_TYPE_ARRAY_SIZE (type);
+
+	  if (stride && !INTEGER_CST_P (stride))
+	    {
+	      /* Calculate size = stride * (ubound + 1 - lbound).  */
+	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+				 gfc_index_one_node, lbound);
+	      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+				 ubound, tmp);
+	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+				 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+	      gfc_add_modify_expr (&block, stride, tmp);
+	    }
+	}
     }
 
   /* Set the offset.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
     gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
 
+  gfc_trans_vla_type_sizes (sym, &block);
+
   stmt = gfc_finish_block (&block);
 
   gfc_start_block (&block);
@@ -4268,7 +4290,10 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
-    gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+    {
+      gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+      gfc_trans_vla_type_sizes (sym, &fnblock);
+    }
 
   /* Dummy and use associated variables don't need anything special.  */
   if (sym->attr.dummy || sym->attr.use_assoc)

gcc/fortran/trans-decl.c

@@ -55,8 +55,8 @@ static GTY(()) tree current_function_return_label;
 
 /* Holds the variable DECLs for the current function.  */
 
-static GTY(()) tree saved_function_decls = NULL_TREE;
-static GTY(()) tree saved_parent_function_decls = NULL_TREE;
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;
 
 
 /* The namespace of the module we're currently generating.  Only used while
@@ -614,6 +614,30 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
       else
 	gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
     }
+
+  if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+      && sym->as->type != AS_ASSUMED_SIZE)
+    GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+
+  if (POINTER_TYPE_P (type))
+    {
+      gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
+      gcc_assert (TYPE_LANG_SPECIFIC (type)
+		  == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
+      type = TREE_TYPE (type);
+    }
+
+  if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+    {
+      tree size, range;
+
+      size = build2 (MINUS_EXPR, gfc_array_index_type,
+		     GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+      range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				size);
+      TYPE_DOMAIN (type) = range;
+      layout_type (type);
+    }
 }
 
 
@@ -762,7 +786,8 @@ gfc_create_string_length (gfc_symbol * sym)
 			   gfc_charlen_type_node);
       DECL_ARTIFICIAL (length) = 1;
       TREE_USED (length) = 1;
-      gfc_defer_symbol_init (sym);
+      if (sym->ns->proc_name->tlink != NULL)
+	gfc_defer_symbol_init (sym);
       sym->ts.cl->backend_decl = length;
     }
 
@@ -810,9 +835,7 @@ tree
 gfc_get_symbol_decl (gfc_symbol * sym)
 {
   tree decl;
-  tree etype = NULL_TREE;
   tree length = NULL_TREE;
-  tree tmp = NULL_TREE;
   int byref;
 
   gcc_assert (sym->attr.referenced);
@@ -843,28 +866,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       if (sym->ts.type == BT_CHARACTER)
 	{
 	  if (sym->ts.cl->backend_decl == NULL_TREE)
+	    length = gfc_create_string_length (sym);
+	  else
+	    length = sym->ts.cl->backend_decl;
+	  if (TREE_CODE (length) == VAR_DECL
+	      && DECL_CONTEXT (length) == NULL_TREE)
 	    {
-	      length = gfc_create_string_length (sym);
-	      if (TREE_CODE (length) != INTEGER_CST)
-		{
-		  gfc_finish_var_decl (length, sym);
-		  gfc_defer_symbol_init (sym);
-		}
-	    }
-
-	  /* Set the element size of automatic and assumed character length
-	     length, dummy, pointer arrays.  */
-	  if (sym->attr.pointer && sym->attr.dummy
-		&& sym->attr.dimension)
-	    {
-	      tmp = build_fold_indirect_ref (sym->backend_decl);
-	      etype = gfc_get_element_type (TREE_TYPE (tmp));
-	      if (TYPE_SIZE_UNIT (etype) == NULL_TREE)
-		{
-		  tmp = TYPE_SIZE_UNIT (gfc_character1_type_node);
-		  tmp = fold_convert (TREE_TYPE (tmp), sym->ts.cl->backend_decl);
-		  TYPE_SIZE_UNIT (etype) = tmp;
-		}
+	      gfc_finish_var_decl (length, sym);
+	      gfc_defer_symbol_init (sym);
 	    }
 	}
 
@@ -1241,9 +1250,8 @@ create_function_arglist (gfc_symbol * sym)
 {
   tree fndecl;
   gfc_formal_arglist *f;
-  tree typelist;
-  tree arglist;
-  tree length;
+  tree typelist, hidden_typelist;
+  tree arglist, hidden_arglist;
   tree type;
   tree parm;
 
@@ -1252,6 +1260,7 @@ create_function_arglist (gfc_symbol * sym)
   /* Build formal argument list. Make sure that their TREE_CONTEXT is
      the new FUNCTION_DECL node.  */
   arglist = NULL_TREE;
+  hidden_arglist = NULL_TREE;
   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
 
   if (sym->attr.entry_master)
@@ -1270,131 +1279,186 @@ create_function_arglist (gfc_symbol * sym)
 
   if (gfc_return_by_reference (sym))
     {
-      type = TREE_VALUE (typelist);
-      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
-
-      DECL_CONTEXT (parm) = fndecl;
-      DECL_ARG_TYPE (parm) = type;
-      TREE_READONLY (parm) = 1;
-      DECL_ARTIFICIAL (parm) = 1;
-      gfc_finish_decl (parm, NULL_TREE);
-
-      arglist = chainon (arglist, parm);
-      typelist = TREE_CHAIN (typelist);
+      tree type = TREE_VALUE (typelist), length = NULL;
 
       if (sym->ts.type == BT_CHARACTER)
 	{
-	  gfc_allocate_lang_decl (parm);
-
 	  /* Length of character result.  */
-	  type = TREE_VALUE (typelist);
-	  gcc_assert (type == gfc_charlen_type_node);
+	  tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+	  gcc_assert (len_type == gfc_charlen_type_node);
 
 	  length = build_decl (PARM_DECL,
 			       get_identifier (".__result"),
-			       type);
+			       len_type);
 	  if (!sym->ts.cl->length)
 	    {
 	      sym->ts.cl->backend_decl = length;
 	      TREE_USED (length) = 1;
 	    }
 	  gcc_assert (TREE_CODE (length) == PARM_DECL);
-	  arglist = chainon (arglist, length);
-	  typelist = TREE_CHAIN (typelist);
 	  DECL_CONTEXT (length) = fndecl;
-	  DECL_ARG_TYPE (length) = type;
+	  DECL_ARG_TYPE (length) = len_type;
 	  TREE_READONLY (length) = 1;
 	  DECL_ARTIFICIAL (length) = 1;
 	  gfc_finish_decl (length, NULL_TREE);
-	}
-    }
-
-  for (f = sym->formal; f; f = f->next)
-    {
-      if (f->sym != NULL)	/* ignore alternate returns.  */
-	{
-	  length = NULL_TREE;
+	  if (sym->ts.cl->backend_decl == NULL
+	      || sym->ts.cl->backend_decl == length)
+	    {
+	      gfc_symbol *arg;
+	      tree backend_decl;
 
-	  type = TREE_VALUE (typelist);
+	      if (sym->ts.cl->backend_decl == NULL)
+		{
+		  tree len = build_decl (VAR_DECL,
+					 get_identifier ("..__result"),
+					 gfc_charlen_type_node);
+		  DECL_ARTIFICIAL (len) = 1;
+		  TREE_USED (len) = 1;
+		  sym->ts.cl->backend_decl = len;
+		}
 
-	  /* Build a the argument declaration.  */
-	  parm = build_decl (PARM_DECL,
-			     gfc_sym_identifier (f->sym), type);
+	      /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+	      arg = sym->result ? sym->result : sym;
+	      backend_decl = arg->backend_decl;
+	      /* Temporary clear it, so that gfc_sym_type creates complete
+		 type.  */
+	      arg->backend_decl = NULL;
+	      type = gfc_sym_type (arg);
+	      arg->backend_decl = backend_decl;
+	      type = build_reference_type (type);
+	    }
+	}
 
-	  /* Fill in arg stuff.  */
-	  DECL_CONTEXT (parm) = fndecl;
-	  DECL_ARG_TYPE (parm) = type;
-	  /* All implementation args are read-only.  */
-	  TREE_READONLY (parm) = 1;
+      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
 
-	  gfc_finish_decl (parm, NULL_TREE);
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      TREE_READONLY (parm) = 1;
+      DECL_ARTIFICIAL (parm) = 1;
+      gfc_finish_decl (parm, NULL_TREE);
 
-	  f->sym->backend_decl = parm;
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);
 
-	  arglist = chainon (arglist, parm);
+      if (sym->ts.type == BT_CHARACTER)
+	{
+	  gfc_allocate_lang_decl (parm);
+	  arglist = chainon (arglist, length);
 	  typelist = TREE_CHAIN (typelist);
 	}
     }
 
-  /* Add the hidden string length parameters.  */
-  parm = arglist;
+  hidden_typelist = typelist;
+  for (f = sym->formal; f; f = f->next)
+    if (f->sym != NULL)	/* Ignore alternate returns.  */
+      hidden_typelist = TREE_CHAIN (hidden_typelist);
+
   for (f = sym->formal; f; f = f->next)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];
+
       /* Ignore alternate returns.  */
       if (f->sym == NULL)
 	continue;
 
-      if (f->sym->ts.type != BT_CHARACTER)
-	continue;
-
-      parm = f->sym->backend_decl;
       type = TREE_VALUE (typelist);
-      gcc_assert (type == gfc_charlen_type_node);
 
-      strcpy (&name[1], f->sym->name);
-      name[0] = '_';
-      length = build_decl (PARM_DECL, get_identifier (name), type);
+      if (f->sym->ts.type == BT_CHARACTER)
+	{
+	  tree len_type = TREE_VALUE (hidden_typelist);
+	  tree length = NULL_TREE;
+	  gcc_assert (len_type == gfc_charlen_type_node);
 
-      arglist = chainon (arglist, length);
-      DECL_CONTEXT (length) = fndecl;
-      DECL_ARTIFICIAL (length) = 1;
-      DECL_ARG_TYPE (length) = type;
-      TREE_READONLY (length) = 1;
-      gfc_finish_decl (length, NULL_TREE);
+	  strcpy (&name[1], f->sym->name);
+	  name[0] = '_';
+	  length = build_decl (PARM_DECL, get_identifier (name), len_type);
 
-      /* TODO: Check string lengths when -fbounds-check.  */
+	  hidden_arglist = chainon (hidden_arglist, length);
+	  DECL_CONTEXT (length) = fndecl;
+	  DECL_ARTIFICIAL (length) = 1;
+	  DECL_ARG_TYPE (length) = len_type;
+	  TREE_READONLY (length) = 1;
+	  gfc_finish_decl (length, NULL_TREE);
 
-      /* Use the passed value for assumed length variables.  */
-      if (!f->sym->ts.cl->length)
-	{
-	  TREE_USED (length) = 1;
-	  if (!f->sym->ts.cl->backend_decl)
-	    f->sym->ts.cl->backend_decl = length;
-	  else
+	  /* TODO: Check string lengths when -fbounds-check.  */
+
+	  /* Use the passed value for assumed length variables.  */
+	  if (!f->sym->ts.cl->length)
 	    {
-	      /* there is already another variable using this
-		 gfc_charlen node, build a new one for this variable
-		 and chain it into the list of gfc_charlens.
-		 This happens for e.g. in the case
-		 CHARACTER(*)::c1,c2
-		 since CHARACTER declarations on the same line share
-		 the same gfc_charlen node.  */
-	      gfc_charlen *cl;
+	      TREE_USED (length) = 1;
+	      if (!f->sym->ts.cl->backend_decl)
+		f->sym->ts.cl->backend_decl = length;
+	      else
+		{
+		  /* there is already another variable using this
+		     gfc_charlen node, build a new one for this variable
+		     and chain it into the list of gfc_charlens.
+		     This happens for e.g. in the case
+		     CHARACTER(*)::c1,c2
+		     since CHARACTER declarations on the same line share
+		     the same gfc_charlen node.  */
+		  gfc_charlen *cl;
 	      
-	      cl = gfc_get_charlen ();
-	      cl->backend_decl = length;
-	      cl->next = f->sym->ts.cl->next;
-	      f->sym->ts.cl->next = cl;
-	      f->sym->ts.cl = cl;
+		  cl = gfc_get_charlen ();
+		  cl->backend_decl = length;
+		  cl->next = f->sym->ts.cl->next;
+		  f->sym->ts.cl->next = cl;
+		  f->sym->ts.cl = cl;
+		}
+	    }
+
+	  hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+	  if (f->sym->ts.cl->backend_decl == NULL
+	      || f->sym->ts.cl->backend_decl == length)
+	    {
+	      if (f->sym->ts.cl->backend_decl == NULL)
+		gfc_create_string_length (f->sym);
+
+	      /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+	      if (f->sym->attr.flavor == FL_PROCEDURE)
+		type = build_pointer_type (gfc_get_function_type (f->sym));
+	      else
+		type = gfc_sym_type (f->sym);
 	    }
 	}
 
-      parm = TREE_CHAIN (parm);
+      /* For non-constant length array arguments, make sure they use
+	 a different type node from TYPE_ARG_TYPES type.  */
+      if (f->sym->attr.dimension
+	  && type == TREE_VALUE (typelist)
+	  && TREE_CODE (type) == POINTER_TYPE
+	  && GFC_ARRAY_TYPE_P (type)
+	  && f->sym->as->type != AS_ASSUMED_SIZE
+	  && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
+	{
+	  if (f->sym->attr.flavor == FL_PROCEDURE)
+	    type = build_pointer_type (gfc_get_function_type (f->sym));
+	  else
+	    type = gfc_sym_type (f->sym);
+	}
+
+      /* Build a the argument declaration.  */
+      parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+
+      /* Fill in arg stuff.  */
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      /* All implementation args are read-only.  */
+      TREE_READONLY (parm) = 1;
+
+      gfc_finish_decl (parm, NULL_TREE);
+
+      f->sym->backend_decl = parm;
+
+      arglist = chainon (arglist, parm);
       typelist = TREE_CHAIN (typelist);
     }
 
-  gcc_assert (TREE_VALUE (typelist) == void_type_node);
+  /* Add the hidden string length parameters.  */
+  arglist = chainon (arglist, hidden_arglist);
+
+  gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
   DECL_ARGUMENTS (fndecl) = arglist;
 }
 
@@ -1658,18 +1722,24 @@ gfc_create_function_decl (gfc_namespace * ns)
 tree
 gfc_get_fake_result_decl (gfc_symbol * sym)
 {
-  tree decl;
-  tree length;
+  tree decl, length;
 
   char name[GFC_MAX_SYMBOL_LEN + 10];
 
   if (sym
       && sym->ns->proc_name->backend_decl == current_function_decl
-      && sym->ns->proc_name->attr.mixed_entry_master
+      && sym->ns->proc_name->attr.entry_master
       && sym != sym->ns->proc_name)
     {
+      tree t = NULL, var;
+      if (current_fake_result_decl != NULL)
+	for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
+	  if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+	    break;
+      if (t)
+	return TREE_VALUE (t);
       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
-      if (decl)
+      if (decl && sym->ns->proc_name->attr.mixed_entry_master)
 	{
 	  tree field;
 
@@ -1683,22 +1753,32 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
 	  decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
 			 NULL_TREE);
 	}
-      return decl;
+      var = gfc_create_var (TREE_TYPE (decl), sym->name);
+      SET_DECL_VALUE_EXPR (var, decl);
+      DECL_HAS_VALUE_EXPR_P (var) = 1;
+      TREE_CHAIN (current_fake_result_decl)
+	= tree_cons (get_identifier (sym->name), var,
+		     TREE_CHAIN (current_fake_result_decl));
+      return var;
     }
 
   if (current_fake_result_decl != NULL_TREE)
-    return current_fake_result_decl;
+    return TREE_VALUE (current_fake_result_decl);
 
   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
      sym is NULL.  */
   if (!sym)
     return NULL_TREE;
 
-  if (sym->ts.type == BT_CHARACTER
-      && !sym->ts.cl->backend_decl)
+  if (sym->ts.type == BT_CHARACTER)
     {
-      length = gfc_create_string_length (sym);
-      gfc_finish_var_decl (length, sym);
+      if (sym->ts.cl->backend_decl == NULL_TREE)
+	length = gfc_create_string_length (sym);
+      else
+	length = sym->ts.cl->backend_decl;
+      if (TREE_CODE (length) == VAR_DECL
+	  && DECL_CONTEXT (length) == NULL_TREE)
+	gfc_finish_var_decl (length, sym);
     }
 
   if (gfc_return_by_reference (sym))
@@ -1731,7 +1811,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
       gfc_add_decl_to_function (decl);
     }
 
-  current_fake_result_decl = decl;
+  current_fake_result_decl = build_tree_list (NULL, decl);
 
   return decl;
 }
@@ -2174,7 +2254,7 @@ gfc_build_builtin_function_decls (void)
 /* Evaluate the length of dummy character variables.  */
 
 static tree
-gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
 {
   stmtblock_t body;
 
@@ -2184,7 +2264,9 @@ gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
 
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (cl, &body);
-  
+
+  gfc_trans_vla_type_sizes (sym, &body);
+
   gfc_add_expr_to_block (&body, fnbody);
   return gfc_finish_block (&body);
 }
@@ -2207,6 +2289,8 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (sym->ts.cl, &body);
 
+  gfc_trans_vla_type_sizes (sym, &body);
+
   decl = sym->backend_decl;
 
   /* Emit a DECL_EXPR for this variable, which will cause the
@@ -2237,6 +2321,112 @@ gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
   return gfc_finish_block (&body);
 }
 
+static void
+gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+{
+  tree t = *tp, var, val;
+
+  if (t == NULL || t == error_mark_node)
+    return;
+  if (TREE_CONSTANT (t) || DECL_P (t))
+    return;
+
+  if (TREE_CODE (t) == SAVE_EXPR)
+    {
+      if (SAVE_EXPR_RESOLVED_P (t))
+	{
+	  *tp = TREE_OPERAND (t, 0);
+	  return;
+	}
+      val = TREE_OPERAND (t, 0);
+    }
+  else
+    val = t;
+
+  var = gfc_create_var_np (TREE_TYPE (t), NULL);
+  gfc_add_decl_to_function (var);
+  gfc_add_modify_expr (body, var, val);
+  if (TREE_CODE (t) == SAVE_EXPR)
+    TREE_OPERAND (t, 0) = var;
+  *tp = var;
+}
+
+static void
+gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+{
+  tree t;
+
+  if (type == NULL || type == error_mark_node)
+    return;
+
+  type = TYPE_MAIN_VARIANT (type);
+
+  if (TREE_CODE (type) == INTEGER_TYPE)
+    {
+      gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+	{
+	  TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
+	  TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
+	}
+    }
+  else if (TREE_CODE (type) == ARRAY_TYPE)
+    {
+      gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
+      gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+	{
+	  TYPE_SIZE (t) = TYPE_SIZE (type);
+	  TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
+	}
+    }
+}
+
+/* Make sure all type sizes and array domains are either constant,
+   or variable or parameter decls.  This is a simplified variant
+   of gimplify_type_sizes, but we can't use it here, as none of the
+   variables in the expressions have been gimplified yet.
+   As type sizes and domains for various variable length arrays
+   contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
+   time, without this routine gimplify_type_sizes in the middle-end
+   could result in the type sizes being gimplified earlier than where
+   those variables are initialized.  */
+
+void
+gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
+{
+  tree type = TREE_TYPE (sym->backend_decl);
+
+  if (TREE_CODE (type) == FUNCTION_TYPE
+      && (sym->attr.function || sym->attr.result || sym->attr.entry))
+    {
+      if (! current_fake_result_decl)
+	return;
+
+      type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+    }
+
+  while (POINTER_TYPE_P (type))
+    type = TREE_TYPE (type);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+      while (POINTER_TYPE_P (etype))
+	etype = TREE_TYPE (etype);
+
+      gfc_trans_vla_type_sizes_1 (etype, body);
+    }
+
+  gfc_trans_vla_type_sizes_1 (type, body);
+}
+
 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
@@ -2250,6 +2440,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 {
   locus loc;
   gfc_symbol *sym;
+  gfc_formal_arglist *f;
+  stmtblock_t body;
 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
@@ -2269,14 +2461,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	}
       else if (proc_sym->as)
 	{
-	  fnbody = gfc_trans_dummy_array_bias (proc_sym,
-					       current_fake_result_decl,
-					       fnbody);
+	  tree result = TREE_VALUE (current_fake_result_decl);
+	  fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
 	  if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
-	    fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
+	    fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+						fnbody);
 	}
       else
 	gcc_assert (gfc_option.flag_f2c
@@ -2339,7 +2531,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	  gfc_get_backend_locus (&loc);
 	  gfc_set_backend_locus (&sym->declared_at);
 	  if (sym->attr.dummy || sym->attr.result)
-	    fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
+	    fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
 	  else
 	    fnbody = gfc_trans_auto_character_variable (sym, fnbody);
 	  gfc_set_backend_locus (&loc);
@@ -2355,7 +2547,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	gcc_unreachable ();
     }
 
-  return fnbody;
+  gfc_init_block (&body);
+
+  for (f = proc_sym->formal; f; f = f->next)
+    if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+      {
+	gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+	if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+	  gfc_trans_vla_type_sizes (f->sym, &body);
+      }
+
+  if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+      && current_fake_result_decl != NULL)
+    {
+      gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
+      if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+	gfc_trans_vla_type_sizes (proc_sym, &body);
+    }
+
+  gfc_add_expr_to_block (&body, fnbody);
+  return gfc_finish_block (&body);
 }
 
 
@@ -2477,6 +2688,19 @@ generate_local_decl (gfc_symbol * sym)
       else if (warn_unused_variable
 	       && !(sym->attr.in_common || sym->attr.use_assoc))
 	warning (0, "unused variable %qs", sym->name); 
+      /* For variable length CHARACTER parameters, the PARM_DECL already
+	 references the length variable, so force gfc_get_symbol_decl
+	 even when not referenced.  If optimize > 0, it will be optimized
+	 away anyway.  But do this only after emitting -Wunused-parameter
+	 warning if requested.  */
+      if (sym->attr.dummy && ! sym->attr.referenced
+	  && sym->ts.type == BT_CHARACTER
+	  && sym->ts.cl->backend_decl != NULL
+	  && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+	{
+	  sym->attr.referenced = 1;
+	  gfc_get_symbol_decl (sym);
+	}
     }
 }
 
@@ -2655,7 +2879,10 @@ gfc_generate_function_code (gfc_namespace * ns)
     {
       if (sym->attr.subroutine || sym == sym->result)
 	{
-	  result = current_fake_result_decl;
+	  if (current_fake_result_decl != NULL)
+	    result = TREE_VALUE (current_fake_result_decl);
+	  else
+	    result = NULL_TREE;
 	  current_fake_result_decl = NULL_TREE;
 	}
       else

gcc/fortran/trans-expr.c

@@ -2656,7 +2656,7 @@ gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
 }
 
 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
-   numeric expressions.  Used for scalar values whee inserting cleanup code
+   numeric expressions.  Used for scalar values where inserting cleanup code
    is inconvenient.  */
 void
 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)

gcc/fortran/trans-stmt.c

@@ -701,7 +701,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
    to:
 
    [evaluate loop bounds and step]
-   count = to + step - from;
+   count = (to + step - from) / step;
    dovar = from;
    for (;;)
      {

gcc/fortran/trans.h

@@ -320,6 +320,8 @@ tree gfc_conv_string_tmp (gfc_se *, tree, tree);
 tree gfc_get_expr_charlen (gfc_expr *);
 /* Initialize a string length variable.  */
 void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
+/* Ensure type sizes can be gimplified.  */
+void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
 
 /* Add an expression to the end of a block.  */
 void gfc_add_expr_to_block (stmtblock_t *, tree);