X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-expr.c;h=42e1d34d38ccf6345979d820a5664c182f94520e;hb=ea475d4a177dd7007de34360115ec390b4d18ec6;hp=77a2dfae3563c6330f41ca3918c6b70f7ae8cf96;hpb=e5387fb99fe093bfb88341e8dfc667ea3556c307;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 77a2dfae356..42e1d34d38c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,5 +1,5 @@
 /* Expression translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "flags.h"
 #include "gfortran.h"
 #include "arith.h"
+#include "constructor.h"
 #include "trans.h"
 #include "trans-const.h"
 #include "trans-types.h"
@@ -158,7 +159,8 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
     {
       /* Create a temporary and convert it to the correct type.  */
       tmp = gfc_get_int_type (kind);
-      tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
+      tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
+							se->expr));
     
       /* Test for a NULL value.  */
       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
@@ -200,12 +202,12 @@ gfc_get_expr_charlen (gfc_expr *e)
   
   length = NULL; /* To silence compiler warning.  */
 
-  if (is_subref_array (e) && e->ts.cl->length)
+  if (is_subref_array (e) && e->ts.u.cl->length)
     {
       gfc_se tmpse;
       gfc_init_se (&tmpse, NULL);
-      gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
-      e->ts.cl->backend_decl = tmpse.expr;
+      gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
+      e->ts.u.cl->backend_decl = tmpse.expr;
       return tmpse.expr;
     }
 
@@ -213,7 +215,7 @@ gfc_get_expr_charlen (gfc_expr *e)
      expression's length could be the length of the character
      variable.  */
   if (e->symtree->n.sym->ts.type == BT_CHARACTER)
-    length = e->symtree->n.sym->ts.cl->backend_decl;
+    length = e->symtree->n.sym->ts.u.cl->backend_decl;
 
   /* Look through the reference chain for component references.  */
   for (r = e->ref; r; r = r->next)
@@ -222,7 +224,7 @@ gfc_get_expr_charlen (gfc_expr *e)
 	{
 	case REF_COMPONENT:
 	  if (r->u.c.component->ts.type == BT_CHARACTER)
-	    length = r->u.c.component->ts.cl->backend_decl;
+	    length = r->u.c.component->ts.u.cl->backend_decl;
 	  break;
 
 	case REF_ARRAY:
@@ -242,7 +244,7 @@ gfc_get_expr_charlen (gfc_expr *e)
 }
 
 
-/* For each character array constructor subexpression without a ts.cl->length,
+/* For each character array constructor subexpression without a ts.u.cl->length,
    replace it by its first element (if there aren't any elements, the length
    should already be set to zero).  */
 
@@ -275,13 +277,16 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
     case EXPR_ARRAY:
 
       /* We've found what we're looking for.  */
-      if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+      if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
 	{
+	  gfc_constructor *c;
 	  gfc_expr* new_expr;
+
 	  gcc_assert (e->value.constructor);
 
-	  new_expr = e->value.constructor->expr;
-	  e->value.constructor->expr = NULL;
+	  c = gfc_constructor_first (e->value.constructor);
+	  new_expr = c->expr;
+	  c->expr = NULL;
 
 	  flatten_array_ctors_without_strlen (new_expr);
 	  gfc_replace_expr (e, new_expr);
@@ -290,7 +295,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
 
       /* Otherwise, fall through to handle constructor elements.  */
     case EXPR_STRUCTURE:
-      for (c = e->value.constructor; c; c = c->next)
+      for (c = gfc_constructor_first (e->value.constructor);
+	   c; c = gfc_constructor_next (c))
 	flatten_array_ctors_without_strlen (c->expr);
       break;
 
@@ -355,7 +361,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
 {
   tree tmp;
   tree type;
-  tree var;
   tree fault;
   gfc_se start;
   gfc_se end;
@@ -364,7 +369,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
   type = gfc_get_character_type (kind, ref->u.ss.length);
   type = build_pointer_type (type);
 
-  var = NULL_TREE;
   gfc_init_se (&start, se);
   gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
   gfc_add_block_to_block (&se->pre, &start.pre);
@@ -373,15 +377,18 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
     gfc_conv_string_parameter (se);
   else
     {
+      tmp = start.expr;
+      STRIP_NOPS (tmp);
       /* Avoid multiple evaluation of substring start.  */
-      if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
+      if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
 	start.expr = gfc_evaluate_now (start.expr, &se->pre);
 
       /* Change the start of the string.  */
       if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
 	tmp = se->expr;
       else
-	tmp = build_fold_indirect_ref (se->expr);
+	tmp = build_fold_indirect_ref_loc (input_location,
+				       se->expr);
       tmp = gfc_build_array_ref (tmp, start.expr, NULL);
       se->expr = gfc_build_addr_expr (type, tmp);
     }
@@ -395,7 +402,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
       gfc_add_block_to_block (&se->pre, &end.pre);
     }
-  if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
+  tmp = end.expr;
+  STRIP_NOPS (tmp);
+  if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
     end.expr = gfc_evaluate_now (end.expr, &se->pre);
 
   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
@@ -438,9 +447,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
     }
 
   tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
-		     build_int_cst (gfc_charlen_type_node, 1),
-		     start.expr);
-  tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
+		     end.expr, start.expr);
+  tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+		     build_int_cst (gfc_charlen_type_node, 1), tmp);
   tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
 		     build_int_cst (gfc_charlen_type_node, 0));
   se->string_length = tmp;
@@ -468,16 +477,19 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
 
   se->expr = tmp;
 
-  if (c->ts.type == BT_CHARACTER)
+  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
     {
-      tmp = c->ts.cl->backend_decl;
+      tmp = c->ts.u.cl->backend_decl;
       /* Components must always be constant length.  */
       gcc_assert (tmp && INTEGER_CST_P (tmp));
       se->string_length = tmp;
     }
 
-  if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
-    se->expr = build_fold_indirect_ref (se->expr);
+  if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+       && c->ts.type != BT_CHARACTER)
+      || c->attr.proc_pointer)
+    se->expr = build_fold_indirect_ref_loc (input_location,
+					se->expr);
 }
 
 
@@ -500,16 +512,23 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
   parent.u.c.sym = dt;
   parent.u.c.component = dt->components;
 
+  if (dt->backend_decl == NULL)
+    gfc_get_derived_type (dt);
+
   if (dt->attr.extension && dt->components)
     {
+      if (dt->attr.is_class)
+	cmp = dt->components;
+      else
+	cmp = dt->components->next;
       /* Return if the component is not in the parent type.  */
-      for (cmp = dt->components->next; cmp; cmp = cmp->next)
+      for (; cmp; cmp = cmp->next)
 	if (strcmp (c->name, cmp->name) == 0)
 	  return;
 	
       /* Otherwise build the reference and call self.  */
       gfc_conv_component_ref (se, &parent);
-      parent.u.c.sym = dt->components->ts.derived;
+      parent.u.c.sym = dt->components->ts.u.derived;
       parent.u.c.component = c;
       conv_parent_component_references (se, &parent);
     }
@@ -620,21 +639,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	      && (sym->attr.dummy
 		  || sym->attr.function
 		  || sym->attr.result))
-	    se->expr = build_fold_indirect_ref (se->expr);
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 
 	}
       else if (!sym->attr.value)
 	{
           /* Dereference non-character scalar dummy arguments.  */
 	  if (sym->attr.dummy && !sym->attr.dimension)
-	    se->expr = build_fold_indirect_ref (se->expr);
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 
           /* Dereference scalar hidden result.  */
 	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
 	      && (sym->attr.function || sym->attr.result)
 	      && !sym->attr.dimension && !sym->attr.pointer
 	      && !sym->attr.always_explicit)
-	    se->expr = build_fold_indirect_ref (se->expr);
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 
           /* Dereference non-character pointer variables. 
 	     These must be dummies, results, or scalars.  */
@@ -643,7 +665,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 		  || sym->attr.function
 		  || sym->attr.result
 		  || !sym->attr.dimension))
-	    se->expr = build_fold_indirect_ref (se->expr);
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 	}
 
       ref = expr->ref;
@@ -654,10 +677,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
     {
       /* If the character length of an entry isn't set, get the length from
          the master function instead.  */
-      if (sym->attr.entry && !sym->ts.cl->backend_decl)
-        se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
+      if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
+        se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
       else
-        se->string_length = sym->ts.cl->backend_decl;
+        se->string_length = sym->ts.u.cl->backend_decl;
       gcc_assert (se->string_length);
     }
 
@@ -702,7 +725,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
      separately.  */
   if (se->want_pointer)
     {
-      if (expr->ts.type == BT_CHARACTER)
+      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
 	gfc_conv_string_parameter (se);
       else 
 	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
@@ -1079,7 +1102,8 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
       break;
     }
 
-  se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
+  se->expr = build_call_expr_loc (input_location,
+			      fndecl, 2, lse.expr, rse.expr);
 }
 
 
@@ -1091,7 +1115,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
   tree var;
   tree tmp;
 
-  gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
+  gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
 
   if (gfc_can_put_var_on_stack (len))
     {
@@ -1119,8 +1143,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
       gfc_add_modify (&se->pre, var, tmp);
 
       /* Free the temporary afterwards.  */
-      tmp = gfc_call_free (var, true, &gfc_current_locus,
-			   ALLOCTYPE_TEMPORARY);
+      tmp = gfc_call_free (convert (pvoid_type_node, var));
       gfc_add_expr_to_block (&se->post, tmp);
     }
 
@@ -1151,7 +1174,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
   gfc_add_block_to_block (&se->pre, &lse.pre);
   gfc_add_block_to_block (&se->pre, &rse.pre);
 
-  type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
   if (len == NULL_TREE)
     {
@@ -1171,7 +1194,8 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
   else
     gcc_unreachable ();
 
-  tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
+  tmp = build_call_expr_loc (input_location,
+			 fndecl, 6, len, var, lse.string_length, lse.expr,
 			 rse.string_length, rse.expr);
   gfc_add_expr_to_block (&se->pre, tmp);
 
@@ -1206,8 +1230,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
   switch (expr->value.op.op)
     {
     case INTRINSIC_PARENTHESES:
-      if (expr->ts.type == BT_REAL
-	  || expr->ts.type == BT_COMPLEX)
+      if ((expr->ts.type == BT_REAL
+	   || expr->ts.type == BT_COMPLEX)
+	  && gfc_option.flag_protect_parens)
 	{
 	  gfc_conv_unary_op (PAREN_EXPR, se, expr);
 	  gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
@@ -1378,7 +1403,8 @@ string_to_single_character (tree len, tree str, int kind)
       && TREE_INT_CST_HIGH (len) == 0)
     {
       str = fold_convert (gfc_get_pchar_type (kind), str);
-      return build_fold_indirect_ref (str);
+      return build_fold_indirect_ref_loc (input_location,
+				      str);
     }
 
   return NULL_TREE;
@@ -1411,7 +1437,8 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
 	  gfc_typespec ts;
           gfc_clear_ts (&ts);
 
-	  *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
+	  *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				    (int)(*expr)->value.character.string[0]);
 	  if ((*expr)->ts.kind != gfc_c_int_kind)
 	    {
   	      /* The expr needs to be compatible with a C int.  If the 
@@ -1481,22 +1508,173 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
       else
 	gcc_unreachable ();
 
-      tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
+      tmp = build_call_expr_loc (input_location,
+			     fndecl, 4, len1, str1, len2, str2);
     }
 
   return tmp;
 }
 
+
+/* Return the backend_decl for a procedure pointer component.  */
+
+static tree
+get_proc_ptr_comp (gfc_expr *e)
+{
+  gfc_se comp_se;
+  gfc_expr *e2;
+  gfc_init_se (&comp_se, NULL);
+  e2 = gfc_copy_expr (e);
+  e2->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e2);
+  gfc_free_expr (e2);
+  return build_fold_addr_expr_loc (input_location, comp_se.expr);
+}
+
+
+/* Select a class typebound procedure at runtime.  */
 static void
-gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+		   tree declared, gfc_expr *expr)
 {
+  tree end_label;
+  tree label;
   tree tmp;
+  tree hash;
+  stmtblock_t body;
+  gfc_class_esym_list *next_elist, *tmp_elist;
+  gfc_se tmpse;
 
-  if (sym->attr.dummy)
+  /* Convert the hash expression.  */
+  gfc_init_se (&tmpse, NULL);
+  gfc_conv_expr (&tmpse, elist->hash_value);
+  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+  hash = gfc_evaluate_now (tmpse.expr, &se->pre);
+  gfc_add_block_to_block (&se->post, &tmpse.post);
+
+  /* Fix the function type to be that of the declared type method.  */
+  declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+  end_label = gfc_build_label_decl (NULL_TREE);
+
+  gfc_init_block (&body);
+
+  /* Go through the list of extensions.  */
+  for (; elist; elist = next_elist)
+    {
+      /* This case has already been added.  */
+      if (elist->derived == NULL)
+	goto free_elist;
+
+      /* Skip abstract base types.  */
+      if (elist->derived->attr.abstract)
+       goto free_elist;
+
+      /* Run through the chain picking up all the cases that call the
+	 same procedure.  */
+      tmp_elist = elist;
+      for (; elist; elist = elist->next)
+	{
+	  tree cval;
+
+	  if (elist->esym != tmp_elist->esym)
+	    continue;
+
+	  cval = build_int_cst (TREE_TYPE (hash),
+				elist->derived->hash_value);
+	  /* Build a label for the hash value.  */
+	  label = gfc_build_label_decl (NULL_TREE);
+	  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+			     cval, NULL_TREE, label);
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  /* Null the reference the derived type so that this case is
+	     not used again.  */
+	  elist->derived = NULL;
+	}
+
+      elist = tmp_elist;
+
+      /* Get a pointer to the procedure,  */
+      tmp = gfc_get_symbol_decl (elist->esym);
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      /* Assign the pointer to the appropriate procedure.  */
+      gfc_add_modify (&body, declared,
+		      fold_convert (TREE_TYPE (declared), tmp));
+
+      /* Break to the end of the construct.  */
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Free the elists as we go; freeing them in gfc_free_expr causes
+	 segfaults because it occurs too early and too often.  */
+    free_elist:
+      next_elist = elist->next;
+      if (elist->hash_value)
+	gfc_free_expr (elist->hash_value);
+      gfc_free (elist);
+      elist = NULL;
+    }
+
+  /* Default is an error.  */
+  label = gfc_build_label_decl (NULL_TREE);
+  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+		     NULL_TREE, NULL_TREE, label);
+  gfc_add_expr_to_block (&body, tmp);
+  tmp = gfc_trans_runtime_error (true, &expr->where,
+		"internal error: bad hash value in dynamic dispatch");
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Write the switch expression.  */
+  tmp = gfc_finish_block (&body);
+  tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = declared;
+  return;
+}
+
+
+static void
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+{
+  tree tmp;
+
+  if (expr && expr->symtree
+	&& expr->value.function.class_esym)
+    {
+      if (!sym->backend_decl)
+	sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+      tmp = sym->backend_decl;
+
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      select_class_proc (se, expr->value.function.class_esym,
+			 tmp, expr);
+      return;
+    }
+
+  if (gfc_is_proc_ptr_comp (expr, NULL))
+    tmp = get_proc_ptr_comp (expr);
+  else if (sym->attr.dummy)
     {
       tmp = gfc_get_symbol_decl (sym);
       if (sym->attr.proc_pointer)
-        tmp = build_fold_indirect_ref (tmp);
+        tmp = build_fold_indirect_ref_loc (input_location,
+				       tmp);
       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
 	      && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
     }
@@ -1527,48 +1705,6 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
 }
 
 
-/* Translate the call for an elemental subroutine call used in an operator
-   assignment.  This is a simplified version of gfc_conv_function_call.  */
-
-tree
-gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
-{
-  tree args;
-  tree tmp;
-  gfc_se se;
-  stmtblock_t block;
-
-  /* Only elemental subroutines with two arguments.  */
-  gcc_assert (sym->attr.elemental && sym->attr.subroutine);
-  gcc_assert (sym->formal->next->next == NULL);
-
-  gfc_init_block (&block);
-
-  gfc_add_block_to_block (&block, &lse->pre);
-  gfc_add_block_to_block (&block, &rse->pre);
-
-  /* Build the argument list for the call, including hidden string lengths.  */
-  args = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL_TREE, lse->expr));
-  args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, rse->expr));
-  if (lse->string_length != NULL_TREE)
-    args = gfc_chainon_list (args, lse->string_length);
-  if (rse->string_length != NULL_TREE)
-    args = gfc_chainon_list (args, rse->string_length);    
-
-  /* Build the function call.  */
-  gfc_init_se (&se, NULL);
-  gfc_conv_function_val (&se, sym);
-  tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
-  tmp = build_call_list (tmp, se.expr, args);
-  gfc_add_expr_to_block (&block, tmp);
-
-  gfc_add_block_to_block (&block, &lse->post);
-  gfc_add_block_to_block (&block, &rse->post);
-
-  return gfc_finish_block (&block);
-}
-
-
 /* Initialize MAPPING.  */
 
 void
@@ -1639,7 +1775,9 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
   tree var;
 
   type = gfc_typenode_for_spec (&sym->ts);
-  type = gfc_get_nodesc_array_type (type, sym->as, packed);
+  type = gfc_get_nodesc_array_type (type, sym->as, packed,
+				    !sym->attr.target && !sym->attr.pointer
+				    && !sym->attr.proc_pointer);
 
   var = gfc_create_var (type, "ifm");
   gfc_add_modify (block, var, fold_convert (type, data));
@@ -1668,15 +1806,15 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
       if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
 	{
 	  GFC_TYPE_ARRAY_LBOUND (type, n)
-		= gfc_conv_descriptor_lbound (desc, dim);
+		= gfc_conv_descriptor_lbound_get (desc, dim);
 	  GFC_TYPE_ARRAY_UBOUND (type, n)
-		= gfc_conv_descriptor_ubound (desc, dim);
+		= gfc_conv_descriptor_ubound_get (desc, dim);
 	}
       else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
 	{
 	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_ubound (desc, dim),
-			     gfc_conv_descriptor_lbound (desc, dim));
+			     gfc_conv_descriptor_ubound_get (desc, dim),
+			     gfc_conv_descriptor_lbound_get (desc, dim));
 	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
 			     GFC_TYPE_ARRAY_LBOUND (type, n),
 			     tmp);
@@ -1716,6 +1854,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   new_sym->as = gfc_copy_array_spec (sym->as);
   new_sym->attr.referenced = 1;
   new_sym->attr.dimension = sym->attr.dimension;
+  new_sym->attr.codimension = sym->attr.codimension;
   new_sym->attr.pointer = sym->attr.pointer;
   new_sym->attr.allocatable = sym->attr.allocatable;
   new_sym->attr.flavor = sym->attr.flavor;
@@ -1751,16 +1890,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   if (sym->ts.type == BT_CHARACTER)
     {
       /* Create a copy of the dummy argument's length.  */
-      new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
-      sm->expr->ts.cl = new_sym->ts.cl;
+      new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
+      sm->expr->ts.u.cl = new_sym->ts.u.cl;
 
       /* If the length is specified as "*", record the length that
 	 the caller is passing.  We should use the callee's length
 	 in all other cases.  */
-      if (!new_sym->ts.cl->length && se)
+      if (!new_sym->ts.u.cl->length && se)
 	{
 	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
-	  new_sym->ts.cl->backend_decl = se->string_length;
+	  new_sym->ts.u.cl->backend_decl = se->string_length;
 	}
     }
 
@@ -1778,7 +1917,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
       tmp = build_pointer_type (tmp);
       if (sym->attr.pointer)
-        value = build_fold_indirect_ref (se->expr);
+        value = build_fold_indirect_ref_loc (input_location,
+					 se->expr);
       else
         value = se->expr;
       value = fold_convert (tmp, value);
@@ -1787,11 +1927,13 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   /* If the argument is a scalar, a pointer to an array or an allocatable,
      dereference it.  */
   else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
-    value = build_fold_indirect_ref (se->expr);
+    value = build_fold_indirect_ref_loc (input_location,
+				     se->expr);
   
   /* For character(*), use the actual argument's descriptor.  */  
-  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
-    value = build_fold_indirect_ref (se->expr);
+  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
+    value = build_fold_indirect_ref_loc (input_location,
+				     se->expr);
 
   /* If the argument is an array descriptor, use it to determine
      information about the actual argument's shape.  */
@@ -1799,7 +1941,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
 	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
     {
       /* Get the actual argument's descriptor.  */
-      desc = build_fold_indirect_ref (se->expr);
+      desc = build_fold_indirect_ref_loc (input_location,
+				      se->expr);
 
       /* Create the replacement variable.  */
       tmp = gfc_conv_descriptor_data_get (desc);
@@ -1833,9 +1976,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
 
   for (sym = mapping->syms; sym; sym = sym->next)
     if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
-	&& !sym->new_sym->n.sym->ts.cl->backend_decl)
+	&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
       {
-	expr = sym->new_sym->n.sym->ts.cl->length;
+	expr = sym->new_sym->n.sym->ts.u.cl->length;
 	gfc_apply_interface_mapping_to_expr (mapping, expr);
 	gfc_init_se (&se, NULL);
 	gfc_conv_expr (&se, expr);
@@ -1844,7 +1987,7 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
 	gfc_add_block_to_block (pre, &se.pre);
 	gfc_add_block_to_block (post, &se.post);
 
-	sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
+	sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
       }
 }
 
@@ -1854,9 +1997,10 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
 
 static void
 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
-				     gfc_constructor * c)
+				     gfc_constructor_base base)
 {
-  for (; c; c = c->next)
+  gfc_constructor *c;
+  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
     {
       gfc_apply_interface_mapping_to_expr (mapping, c->expr);
       if (c->iterator)
@@ -1931,16 +2075,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
     case GFC_ISYM_LEN:
       /* TODO figure out why this condition is necessary.  */
       if (sym->attr.function
-	  && (arg1->ts.cl->length == NULL
-	      || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
-		  && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
+	  && (arg1->ts.u.cl->length == NULL
+	      || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
+		  && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
 	return false;
 
-      new_expr = gfc_copy_expr (arg1->ts.cl->length);
+      new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
       break;
 
     case GFC_ISYM_SIZE:
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
 	return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
@@ -1964,7 +2108,9 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
 	      return false;
 	    }
 
-	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
+					gfc_get_int_expr (gfc_default_integer_kind,
+							  NULL, 1));
 	  tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
 	  if (new_expr)
 	    new_expr = gfc_multiply (new_expr, tmp);
@@ -1978,7 +2124,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
 	/* TODO These implementations of lbound and ubound do not limit if
 	   the size < 0, according to F95's 13.14.53 and 13.14.113.  */
 
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
 	return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
@@ -2049,11 +2195,11 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
 
   if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
     {
-      expr->value.function.esym->ts.cl->length
-	= gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+      expr->value.function.esym->ts.u.cl->length
+	= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
 
       gfc_apply_interface_mapping_to_expr (mapping,
-			expr->value.function.esym->ts.cl->length);
+			expr->value.function.esym->ts.u.cl->length);
     }
 }
 
@@ -2074,10 +2220,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
     return;
 
   /* Copying an expression does not copy its length, so do that here.  */
-  if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+  if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
     {
-      expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
-      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+      expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
+      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
     }
 
   /* Apply the mapping to any references.  */
@@ -2134,6 +2280,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -2161,8 +2308,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    an actual argument derived type array is copied and then returned
    after the function call.  */
 void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
-			   int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+			   sym_intent intent, bool formal_ptr)
 {
   gfc_se lse;
   gfc_se rse;
@@ -2175,8 +2322,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
   tree tmp_index;
   tree tmp;
   tree base_type;
+  tree size;
   stmtblock_t body;
   int n;
+  int dimen;
 
   gcc_assert (expr->expr_type == EXPR_VARIABLE);
 
@@ -2196,8 +2345,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
   gfc_conv_ss_startstride (&loop);
 
   /* Build an ss for the temporary.  */
-  if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
-    gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
+  if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+    gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
 
   base_type = gfc_typenode_for_spec (&expr->ts);
   if (GFC_ARRAY_TYPE_P (base_type)
@@ -2209,7 +2358,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
   loop.temp_ss->data.temp.type = base_type;
 
   if (expr->ts.type == BT_CHARACTER)
-    loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+    loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
   else
     loop.temp_ss->string_length = NULL;
 
@@ -2247,7 +2396,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
 
   if (intent != INTENT_OUT)
     {
-      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
       gfc_add_expr_to_block (&body, tmp);
       gcc_assert (rse.ss == gfc_ss_terminator);
       gfc_trans_scalarizing_loops (&loop, &body);
@@ -2305,9 +2454,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
      outside the innermost loop, so the overall transfer could be
      optimized further.  */
   info = &rse.ss->data.info;
+  dimen = info->dimen;
 
   tmp_index = gfc_index_zero_node;
-  for (n = info->dimen - 1; n > 0; n--)
+  for (n = dimen - 1; n > 0; n--)
     {
       tree tmp_str;
       tmp = rse.loop->loopvar[n];
@@ -2333,17 +2483,18 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
 			   rse.loop->loopvar[0], offset);
 
   /* Now use the offset for the reference.  */
-  tmp = build_fold_indirect_ref (info->data);
+  tmp = build_fold_indirect_ref_loc (input_location,
+				 info->data);
   rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
 
   if (expr->ts.type == BT_CHARACTER)
-    rse.string_length = expr->ts.cl->backend_decl;
+    rse.string_length = expr->ts.u.cl->backend_decl;
 
   gfc_conv_expr (&lse, expr);
 
   gcc_assert (lse.ss == gfc_ss_terminator);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
   gfc_add_expr_to_block (&body, tmp);
   
   /* Generate the copying loops.  */
@@ -2365,7 +2516,43 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
 
   /* Pass the string length to the argument expression.  */
   if (expr->ts.type == BT_CHARACTER)
-    parmse->string_length = expr->ts.cl->backend_decl;
+    parmse->string_length = expr->ts.u.cl->backend_decl;
+
+  /* Determine the offset for pointer formal arguments and set the
+     lbounds to one.  */
+  if (formal_ptr)
+    {
+      size = gfc_index_one_node;
+      offset = gfc_index_zero_node;  
+      for (n = 0; n < dimen; n++)
+	{
+	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+						gfc_rank_cst[n]);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+	  gfc_conv_descriptor_ubound_set (&parmse->pre,
+					  parmse->expr,
+					  gfc_rank_cst[n],
+					  tmp);
+	  gfc_conv_descriptor_lbound_set (&parmse->pre,
+					  parmse->expr,
+					  gfc_rank_cst[n],
+					  gfc_index_one_node);
+	  size = gfc_evaluate_now (size, &parmse->pre);
+	  offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+				offset, size);
+	  offset = gfc_evaluate_now (offset, &parmse->pre);
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     rse.loop->to[n], rse.loop->from[n]);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+	  size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			      size, tmp);
+	}
+
+      gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+				      offset);
+    }
 
   /* We want either the address for the data or the address of the descriptor,
      depending on the mode of passing array arguments.  */
@@ -2401,13 +2588,213 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
+/* Takes a derived type expression and returns the address of a temporary
+   class object of the 'declared' type.  */ 
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+			   gfc_typespec class_ts)
+{
+  gfc_component *cmp;
+  gfc_symbol *vtab;
+  gfc_symbol *declared = class_ts.u.derived;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The derived type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  cmp = gfc_find_component (declared, "$vptr", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+
+  /* Remember the vtab corresponds to the derived type
+    not to the class declared type.  */
+  vtab = gfc_find_derived_vtab (e->ts.u.derived);
+  gcc_assert (vtab);
+  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  cmp = gfc_find_component (declared, "$data", true, true);
+  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		       var, cmp->backend_decl, NULL_TREE);
+  ss = gfc_walk_expr (e);
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      gfc_conv_expr (parmse, e);
+      gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+/* The following routine generates code for the intrinsic
+   procedures from the ISO_C_BINDING module:
+    * C_LOC           (function)
+    * C_FUNLOC        (function)
+    * C_F_POINTER     (subroutine)
+    * C_F_PROCPOINTER (subroutine)
+    * C_ASSOCIATED    (function)
+   One exception which is not handled here is C_F_POINTER with non-scalar
+   arguments. Returns 1 if the call was replaced by inline code (else: 0).  */
+
+static int
+conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
+			    gfc_actual_arglist * arg)
+{
+  gfc_symbol *fsym;
+  gfc_ss *argss;
+    
+  if (sym->intmod_sym_id == ISOCBINDING_LOC)
+    {
+      if (arg->expr->rank == 0)
+	gfc_conv_expr_reference (se, arg->expr);
+      else
+	{
+	  int f;
+	  /* This is really the actual arg because no formal arglist is
+	     created for C_LOC.	 */
+	  fsym = arg->expr->symtree->n.sym;
+
+	  /* We should want it to do g77 calling convention.  */
+	  f = (fsym != NULL)
+	    && !(fsym->attr.pointer || fsym->attr.allocatable)
+	    && fsym->as->type != AS_ASSUMED_SHAPE;
+	  f = f || !sym->attr.always_explicit;
+      
+	  argss = gfc_walk_expr (arg->expr);
+	  gfc_conv_array_parameter (se, arg->expr, argss, f,
+				    NULL, NULL, NULL);
+	}
+
+      /* TODO -- the following two lines shouldn't be necessary, but if
+	 they're removed, a bug is exposed later in the code path.
+	 This workaround was thus introduced, but will have to be
+	 removed; please see PR 35150 for details about the issue.  */
+      se->expr = convert (pvoid_type_node, se->expr);
+      se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+      return 1;
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+    {
+      arg->expr->ts.type = sym->ts.u.derived->ts.type;
+      arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
+      arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
+      gfc_conv_expr_reference (se, arg->expr);
+  
+      return 1;
+    }
+  else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
+	    && arg->next->expr->rank == 0)
+	   || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+    {
+      /* Convert c_f_pointer if fptr is a scalar
+	 and convert c_f_procpointer.  */
+      gfc_se cptrse;
+      gfc_se fptrse;
+
+      gfc_init_se (&cptrse, NULL);
+      gfc_conv_expr (&cptrse, arg->expr);
+      gfc_add_block_to_block (&se->pre, &cptrse.pre);
+      gfc_add_block_to_block (&se->post, &cptrse.post);
+
+      gfc_init_se (&fptrse, NULL);
+      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+	  || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
+	fptrse.want_pointer = 1;
+
+      gfc_conv_expr (&fptrse, arg->next->expr);
+      gfc_add_block_to_block (&se->pre, &fptrse.pre);
+      gfc_add_block_to_block (&se->post, &fptrse.post);
+      
+      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+	  && arg->next->expr->symtree->n.sym->attr.dummy)
+	fptrse.expr = build_fold_indirect_ref_loc (input_location,
+						   fptrse.expr);
+      
+      se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
+			      fptrse.expr,
+			      fold_convert (TREE_TYPE (fptrse.expr),
+					    cptrse.expr));
+
+      return 1;
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+    {
+      gfc_se arg1se;
+      gfc_se arg2se;
+
+      /* Build the addr_expr for the first argument.  The argument is
+	 already an *address* so we don't need to set want_pointer in
+	 the gfc_se.  */
+      gfc_init_se (&arg1se, NULL);
+      gfc_conv_expr (&arg1se, arg->expr);
+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);
+
+      /* See if we were given two arguments.  */
+      if (arg->next == NULL)
+	/* Only given one arg so generate a null and do a
+	   not-equal comparison against the first arg.  */
+	se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+				fold_convert (TREE_TYPE (arg1se.expr),
+					      null_pointer_node));
+      else
+	{
+	  tree eq_expr;
+	  tree not_null_expr;
+	  
+	  /* Given two arguments so build the arg2se from second arg.  */
+	  gfc_init_se (&arg2se, NULL);
+	  gfc_conv_expr (&arg2se, arg->next->expr);
+	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
+	  gfc_add_block_to_block (&se->post, &arg2se.post);
+
+	  /* Generate test to compare that the two args are equal.  */
+	  eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
+				 arg1se.expr, arg2se.expr);
+	  /* Generate test to ensure that the first arg is not null.  */
+	  not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
+				       arg1se.expr, null_pointer_node);
+
+	  /* Finally, the generated test must check that both arg1 is not
+	     NULL and that it is equal to the second arg.  */
+	  se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+				  not_null_expr, eq_expr);
+	}
+
+      return 1;
+    }
+    
+  /* Nothing was done.  */
+  return 0;
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
-   Return nonzero, if the call has alternate specifiers.  */
+   Return nonzero, if the call has alternate specifiers.
+   'expr' is only needed for procedure pointer components.  */
 
 int
-gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
-			gfc_actual_arglist * arg, tree append_args)
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+			 gfc_actual_arglist * arg, gfc_expr * expr,
+			 tree append_args)
 {
   gfc_interface_mapping mapping;
   tree arglist;
@@ -2423,6 +2810,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   tree var;
   tree len;
   tree stringargs;
+  tree result = NULL;
   gfc_formal_arglist *formal;
   int has_alternate_specifier = 0;
   bool need_interface_mapping;
@@ -2433,6 +2821,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   gfc_symbol *fsym;
   stmtblock_t post;
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+  gfc_component *comp = NULL;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -2441,139 +2830,29 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   len = NULL_TREE;
   gfc_clear_ts (&ts);
 
-  if (sym->from_intmod == INTMOD_ISO_C_BINDING)
-    {
-      if (sym->intmod_sym_id == ISOCBINDING_LOC)
-	{
-	  if (arg->expr->rank == 0)
-	    gfc_conv_expr_reference (se, arg->expr);
-	  else
-	    {
-	      int f;
-	      /* This is really the actual arg because no formal arglist is
-		 created for C_LOC.	 */
-	      fsym = arg->expr->symtree->n.sym;
-
-	      /* We should want it to do g77 calling convention.  */
-	      f = (fsym != NULL)
-		&& !(fsym->attr.pointer || fsym->attr.allocatable)
-		&& fsym->as->type != AS_ASSUMED_SHAPE;
-	      f = f || !sym->attr.always_explicit;
-	  
-	      argss = gfc_walk_expr (arg->expr);
-	      gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
-	    }
-
-	  /* TODO -- the following two lines shouldn't be necessary, but
-	    they're removed a bug is exposed later in the codepath.
-	    This is workaround was thus introduced, but will have to be
-	    removed; please see PR 35150 for details about the issue.  */
-	  se->expr = convert (pvoid_type_node, se->expr);
-	  se->expr = gfc_evaluate_now (se->expr, &se->pre);
-
-	  return 0;
-	}
-      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
-	{
-	  arg->expr->ts.type = sym->ts.derived->ts.type;
-	  arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
-	  arg->expr->ts.kind = sym->ts.derived->ts.kind;
-	  gfc_conv_expr_reference (se, arg->expr);
-      
-	  return 0;
-	}
-      else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
-	         && arg->next->expr->rank == 0)
-	       || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
-	{
-	  /* Convert c_f_pointer if fptr is a scalar
-	     and convert c_f_procpointer.  */
-	  gfc_se cptrse;
-	  gfc_se fptrse;
-
-	  gfc_init_se (&cptrse, NULL);
-	  gfc_conv_expr (&cptrse, arg->expr);
-	  gfc_add_block_to_block (&se->pre, &cptrse.pre);
-	  gfc_add_block_to_block (&se->post, &cptrse.post);
-
-	  gfc_init_se (&fptrse, NULL);
-	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
-	      fptrse.want_pointer = 1;
-
-	  gfc_conv_expr (&fptrse, arg->next->expr);
-	  gfc_add_block_to_block (&se->pre, &fptrse.pre);
-	  gfc_add_block_to_block (&se->post, &fptrse.post);
-
-	  tmp = arg->next->expr->symtree->n.sym->backend_decl;
-	  se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
-				  fold_convert (TREE_TYPE (tmp), cptrse.expr));
+  if (sym->from_intmod == INTMOD_ISO_C_BINDING
+      && conv_isocbinding_procedure (se, sym, arg))
+    return 0;
 
-	  return 0;
-	}
-      else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
-        {
-	  gfc_se arg1se;
-	  gfc_se arg2se;
-
-	  /* Build the addr_expr for the first argument.  The argument is
-	     already an *address* so we don't need to set want_pointer in
-	     the gfc_se.  */
-	  gfc_init_se (&arg1se, NULL);
-	  gfc_conv_expr (&arg1se, arg->expr);
-	  gfc_add_block_to_block (&se->pre, &arg1se.pre);
-	  gfc_add_block_to_block (&se->post, &arg1se.post);
-
-	  /* See if we were given two arguments.  */
-	  if (arg->next == NULL)
-	    /* Only given one arg so generate a null and do a
-	       not-equal comparison against the first arg.  */
-	    se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
-				    fold_convert (TREE_TYPE (arg1se.expr),
-						  null_pointer_node));
-	  else
-	    {
-	      tree eq_expr;
-	      tree not_null_expr;
-	      
-	      /* Given two arguments so build the arg2se from second arg.  */
-	      gfc_init_se (&arg2se, NULL);
-	      gfc_conv_expr (&arg2se, arg->next->expr);
-	      gfc_add_block_to_block (&se->pre, &arg2se.pre);
-	      gfc_add_block_to_block (&se->post, &arg2se.post);
-
-	      /* Generate test to compare that the two args are equal.  */
-	      eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
-				     arg1se.expr, arg2se.expr);
-	      /* Generate test to ensure that the first arg is not null.  */
-	      not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
-					   arg1se.expr, null_pointer_node);
-
-	      /* Finally, the generated test must check that both arg1 is not
-		 NULL and that it is equal to the second arg.  */
-	      se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
-				      not_null_expr, eq_expr);
-	    }
+  gfc_is_proc_ptr_comp (expr, &comp);
 
-	  return 0;
-	}
-    }
-  
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
 	{
 	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
-          if (se->ss->useflags)
-            {
-              gcc_assert (gfc_return_by_reference (sym)
-                      && sym->result->attr.dimension);
-              gcc_assert (se->loop != NULL);
-
-              /* Access the previously obtained result.  */
-              gfc_conv_tmp_array_ref (se);
-              gfc_advance_se_ss_chain (se);
-              return 0;
-            }
+	  if (se->ss->useflags)
+	    {
+	      gcc_assert ((!comp && gfc_return_by_reference (sym)
+			   && sym->result->attr.dimension)
+			  || (comp && comp->attr.dimension));
+	      gcc_assert (se->loop != NULL);
+
+	      /* Access the previously obtained result.  */
+	      gfc_conv_tmp_array_ref (se);
+	      gfc_advance_se_ss_chain (se);
+	      return 0;
+	    }
 	}
       info = &se->ss->data.info;
     }
@@ -2582,21 +2861,34 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
-  need_interface_mapping = ((sym->ts.type == BT_CHARACTER
-				  && sym->ts.cl->length
-				  && sym->ts.cl->length->expr_type
-						!= EXPR_CONSTANT)
-			      || sym->attr.dimension);
-  formal = sym->formal;
+  if (!comp)
+    {
+      formal = sym->formal;
+      need_interface_mapping = sym->attr.dimension ||
+			       (sym->ts.type == BT_CHARACTER
+				&& sym->ts.u.cl->length
+				&& sym->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
+  else
+    {
+      formal = comp->formal;
+      need_interface_mapping = comp->attr.dimension ||
+			       (comp->ts.type == BT_CHARACTER
+				&& comp->ts.u.cl->length
+				&& comp->ts.u.cl->length->expr_type
+				   != EXPR_CONSTANT);
+    }
+
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
     {
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
+
       if (e == NULL)
 	{
-
 	  if (se->ignore_optional)
 	    {
 	      /* Some intrinsics have already been resolved to the correct
@@ -2605,23 +2897,31 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else if (arg->label)
 	    {
-              has_alternate_specifier = 1;
-              continue;
+	      has_alternate_specifier = 1;
+	      continue;
 	    }
 	  else
 	    {
 	      /* Pass a NULL pointer for an absent arg.  */
 	      gfc_init_se (&parmse, NULL);
 	      parmse.expr = null_pointer_node;
-              if (arg->missing_arg_type == BT_CHARACTER)
+	      if (arg->missing_arg_type == BT_CHARACTER)
 		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
 	    }
 	}
+      else if (fsym && fsym->ts.type == BT_CLASS
+		 && e->ts.type == BT_DERIVED)
+	{
+	  /* The derived type needs to be converted to a temporary
+	     CLASS object.  */
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
+	}
       else if (se->ss && se->ss->useflags)
 	{
 	  /* An elemental function inside a scalarized loop.  */
-          gfc_init_se (&parmse, se);
-          gfc_conv_expr_reference (&parmse, e);
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_expr_reference (&parmse, e);
 	  parm_kind = ELEMENTAL;
 	}
       else
@@ -2631,7 +2931,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  argss = gfc_walk_expr (e);
 
 	  if (argss == gfc_ss_terminator)
-            {
+	    {
 	      if (e->expr_type == EXPR_VARIABLE
 		    && e->symtree->n.sym->attr.cray_pointee
 		    && fsym && fsym->attr.flavor == FL_PROCEDURE)
@@ -2663,19 +2963,68 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		   through arg->name.  */
 		conv_arglist_function (&parmse, arg->expr, arg->name);
 	      else if ((e->expr_type == EXPR_FUNCTION)
-			  && e->symtree->n.sym->attr.pointer
-			  && fsym && fsym->attr.target)
+			&& ((e->value.function.esym
+			     && e->value.function.esym->result->attr.pointer)
+			    || (!e->value.function.esym
+				&& e->symtree->n.sym->attr.pointer))
+			&& fsym && fsym->attr.target)
 		{
 		  gfc_conv_expr (&parmse, e);
 		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
 		}
+	      else if (e->expr_type == EXPR_FUNCTION
+		       && e->symtree->n.sym->result
+		       && e->symtree->n.sym->result != e->symtree->n.sym
+		       && e->symtree->n.sym->result->attr.proc_pointer)
+		{
+		  /* Functions returning procedure pointers.  */
+		  gfc_conv_expr (&parmse, e);
+		  if (fsym && fsym->attr.proc_pointer)
+		    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		}
 	      else
 		{
 		  gfc_conv_expr_reference (&parmse, e);
+
+		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
+		     allocated on entry, it must be deallocated.  */
+		  if (fsym && fsym->attr.allocatable
+		      && fsym->attr.intent == INTENT_OUT)
+		    {
+		      stmtblock_t block;
+
+		      gfc_init_block  (&block);
+		      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
+							true, NULL);
+		      gfc_add_expr_to_block (&block, tmp);
+		      tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+					 parmse.expr, null_pointer_node);
+		      gfc_add_expr_to_block (&block, tmp);
+
+		      if (fsym->attr.optional
+			  && e->expr_type == EXPR_VARIABLE
+			  && e->symtree->n.sym->attr.optional)
+			{
+			  tmp = fold_build3 (COND_EXPR, void_type_node,
+				     gfc_conv_expr_present (e->symtree->n.sym),
+					    gfc_finish_block (&block),
+					    build_empty_stmt (input_location));
+			}
+		      else
+			tmp = gfc_finish_block (&block);
+
+		      gfc_add_expr_to_block (&se->pre, tmp);
+		    }
+
 		  if (fsym && e->expr_type != EXPR_NULL
 		      && ((fsym->attr.pointer
 			   && fsym->attr.flavor != FL_PROCEDURE)
-			  || fsym->attr.proc_pointer))
+			  || (fsym->attr.proc_pointer
+			      && !(e->expr_type == EXPR_VARIABLE
+			      && e->symtree->n.sym->attr.dummy))
+			  || (e->expr_type == EXPR_VARIABLE
+			      && gfc_is_proc_ptr_comp (e, NULL))
+			  || fsym->attr.allocatable))
 		    {
 		      /* Scalar pointer dummy args require an extra level of
 			 indirection. The null pointer already contains
@@ -2693,11 +3042,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  ALLOCATABLE or assumed shape, we do not use g77's calling
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */
-	      int f;
+	      bool f;
 	      f = (fsym != NULL)
 		  && !(fsym->attr.pointer || fsym->attr.allocatable)
 		  && fsym->as->type != AS_ASSUMED_SHAPE;
-	      f = f || !sym->attr.always_explicit;
+	      if (comp)
+		f = f || !comp->attr.always_explicit;
+	      else
+		f = f || !sym->attr.always_explicit;
 
 	      if (e->expr_type == EXPR_VARIABLE
 		    && is_subref_array (e))
@@ -2706,21 +3058,28 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		   is converted to a temporary, which is passed and then
 		   written back after the procedure call.  */
 		gfc_conv_subref_array_arg (&parmse, e, f,
-			fsym ? fsym->attr.intent : INTENT_INOUT);
+				fsym ? fsym->attr.intent : INTENT_INOUT,
+				fsym && fsym->attr.pointer);
 	      else
 	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
-					  sym->name);
-
-              /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
-                 allocated on entry, it must be deallocated.  */
-              if (fsym && fsym->attr.allocatable
-                  && fsym->attr.intent == INTENT_OUT)
-                {
-                  tmp = build_fold_indirect_ref (parmse.expr);
-                  tmp = gfc_trans_dealloc_allocated (tmp);
-                  gfc_add_expr_to_block (&se->pre, tmp);
-                }
+					  sym->name, NULL);
 
+	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
+		 allocated on entry, it must be deallocated.  */
+	      if (fsym && fsym->attr.allocatable
+		  && fsym->attr.intent == INTENT_OUT)
+		{
+		  tmp = build_fold_indirect_ref_loc (input_location,
+						     parmse.expr);
+		  tmp = gfc_trans_dealloc_allocated (tmp);
+		  if (fsym->attr.optional
+		      && e->expr_type == EXPR_VARIABLE
+		      && e->symtree->n.sym->attr.optional)
+		    tmp = fold_build3 (COND_EXPR, void_type_node,
+				     gfc_conv_expr_present (e->symtree->n.sym),
+				       tmp, build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 	    } 
 	}
 
@@ -2732,9 +3091,23 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       if (e && (fsym == NULL || fsym->attr.optional))
 	{
 	  /* If an optional argument is itself an optional dummy argument,
-	     check its presence and substitute a null if absent.  */
+	     check its presence and substitute a null if absent.  This is
+	     only needed when passing an array to an elemental procedure
+	     as then array elements are accessed - or no NULL pointer is
+	     allowed and a "1" or "0" should be passed if not present.
+	     When passing a non-array-descriptor full array to a
+	     non-array-descriptor dummy, no check is needed. For
+	     array-descriptor actual to array-descriptor dummy, see
+	     PR 41911 for why a check has to be inserted.
+	     fsym == NULL is checked as intrinsics required the descriptor
+	     but do not always set fsym.  */
 	  if (e->expr_type == EXPR_VARIABLE
-	      && e->symtree->n.sym->attr.optional)
+	      && e->symtree->n.sym->attr.optional
+	      && ((e->rank > 0 && sym->attr.elemental)
+		  || e->representation.length || e->ts.type == BT_CHARACTER
+		  || (e->rank > 0
+		      && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
+			  || fsym->as->type == AS_DEFERRED))))
 	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
 				    e->representation.length);
 	}
@@ -2747,11 +3120,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      && parmse.string_length == NULL_TREE
 	      && e->ts.type == BT_PROCEDURE
 	      && e->symtree->n.sym->ts.type == BT_CHARACTER
-	      && e->symtree->n.sym->ts.cl->length != NULL
-	      && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+	      && e->symtree->n.sym->ts.u.cl->length != NULL
+	      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
 	    {
-	      gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
-	      parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+	      gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+	      parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
 	    }
 	}
 
@@ -2765,11 +3138,13 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	 deallocated for non-variable scalars.  Non-variable arrays are
 	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
       if (e && e->ts.type == BT_DERIVED
-	    && e->ts.derived->attr.alloc_comp
+	    && e->ts.u.derived->attr.alloc_comp
+	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
 	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
         {
 	  int parm_rank;
-	  tmp = build_fold_indirect_ref (parmse.expr);
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 parmse.expr);
 	  parm_rank = e->rank;
 	  switch (parm_kind)
 	    {
@@ -2779,7 +3154,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      break;
 
 	    case (SCALAR_POINTER):
-              tmp = build_fold_indirect_ref (tmp);
+              tmp = build_fold_indirect_ref_loc (input_location,
+					     tmp);
 	      break;
 	    }
 
@@ -2789,15 +3165,106 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    {
 	      tree local_tmp;
 	      local_tmp = gfc_evaluate_now (tmp, &se->pre);
-	      local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
 	      gfc_add_expr_to_block (&se->post, local_tmp);
 	    }
 
-	  tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
 
 	  gfc_add_expr_to_block (&se->post, tmp);
         }
 
+      /* Add argument checking of passing an unallocated/NULL actual to
+         a nonallocatable/nonpointer dummy.  */
+
+      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
+        {
+	  symbol_attribute *attr;
+	  char *msg;
+	  tree cond;
+
+	  if (e->expr_type == EXPR_VARIABLE)
+	    attr = &e->symtree->n.sym->attr;
+	  else if (e->expr_type == EXPR_FUNCTION)
+	    {
+	      /* For intrinsic functions, the gfc_attr are not available.  */
+	      if (e->symtree->n.sym->attr.generic && e->value.function.isym)
+		goto end_pointer_check;
+
+	      if (e->symtree->n.sym->attr.generic)
+		attr = &e->value.function.esym->attr;
+	      else
+		attr = &e->symtree->n.sym->result->attr;
+	    }
+	  else
+	    goto end_pointer_check;
+
+          if (attr->optional)
+	    {
+              /* If the actual argument is an optional pointer/allocatable and
+		 the formal argument takes an nonpointer optional value,
+		 it is invalid to pass a non-present argument on, even
+		 though there is no technical reason for this in gfortran.
+		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
+	      tree present, nullptr, type;
+
+	      if (attr->allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+			  "allocated or not present", e->symtree->n.sym->name);
+	      else if (attr->pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else if (attr->proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+			  "associated or not present",
+			  e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+	      present = gfc_conv_expr_present (e->symtree->n.sym);
+	      type = TREE_TYPE (present);
+	      present = fold_build2 (EQ_EXPR, boolean_type_node, present,
+				     fold_convert (type, null_pointer_node));
+	      type = TREE_TYPE (parmse.expr);
+	      nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				     fold_convert (type, null_pointer_node));
+	      cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
+				  present, nullptr);
+	    }
+          else
+	    {
+	      if (attr->allocatable
+		  && (fsym == NULL || !fsym->attr.allocatable))
+		asprintf (&msg, "Allocatable actual argument '%s' is not "
+		      "allocated", e->symtree->n.sym->name);
+	      else if (attr->pointer
+		       && (fsym == NULL || !fsym->attr.pointer))
+		asprintf (&msg, "Pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else if (attr->proc_pointer
+		       && (fsym == NULL || !fsym->attr.proc_pointer))
+		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+		      "associated", e->symtree->n.sym->name);
+	      else
+		goto end_pointer_check;
+
+
+	      cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+				  fold_convert (TREE_TYPE (parmse.expr),
+						null_pointer_node));
+	    }
+ 
+	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
+				   msg);
+	  gfc_free (msg);
+        }
+      end_pointer_check:
+
+
       /* Character strings are passed as two parameters, a length and a
          pointer - except for Bind(c) which only passes the pointer.  */
       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
@@ -2807,12 +3274,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
     }
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
 
-  ts = sym->ts;
+  if (comp)
+    ts = comp->ts;
+  else
+   ts = sym->ts;
+
   if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
     se->string_length = build_int_cst (gfc_charlen_type_node, 1);
   else if (ts.type == BT_CHARACTER)
     {
-      if (sym->ts.cl->length == NULL)
+      if (ts.u.cl->length == NULL)
 	{
 	  /* Assumed character length results are not allowed by 5.1.1.5 of the
 	     standard and are trapped in resolve.c; except in the case of SPREAD
@@ -2827,19 +3298,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      formal = sym->ns->proc_name->formal;
 	      for (; formal; formal = formal->next)
 		if (strcmp (formal->sym->name, sym->name) == 0)
-		  cl.backend_decl = formal->sym->ts.cl->backend_decl;
+		  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
 	    }
         }
-        else
+      else
         {
 	  tree tmp;
 
 	  /* Calculate the length of the returned string.  */
 	  gfc_init_se (&parmse, NULL);
 	  if (need_interface_mapping)
-	    gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+	    gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
 	  else
-	    gfc_conv_expr (&parmse, sym->ts.cl->length);
+	    gfc_conv_expr (&parmse, ts.u.cl->length);
 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
 	  gfc_add_block_to_block (&se->post, &parmse.post);
 	  
@@ -2852,12 +3323,13 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       /* Set up a charlen structure for it.  */
       cl.next = NULL;
       cl.length = NULL;
-      ts.cl = &cl;
+      ts.u.cl = &cl;
 
       len = cl.backend_decl;
     }
 
-  byref = gfc_return_by_reference (sym);
+  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
+	  || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
       if (se->direct_byref)
@@ -2868,11 +3340,38 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
 		&& GFC_DESCRIPTOR_TYPE_P
 			(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
-	    se->expr = build_fold_indirect_ref (se->expr);
+	    se->expr = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 
+	  result = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 	  retargs = gfc_chainon_list (retargs, se->expr);
 	}
-      else if (sym->result->attr.dimension)
+      else if (comp && comp->attr.dimension)
+	{
+	  gcc_assert (se->loop && info);
+
+	  /* Set the type of the array.  */
+	  tmp = gfc_typenode_for_spec (&comp->ts);
+	  info->dimen = se->loop->dimen;
+
+	  /* Evaluate the bounds of the result, if known.  */
+	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+	  /* Create a temporary to store the result.  In case the function
+	     returns a pointer, the temporary will be a shallow copy and
+	     mustn't be deallocated.  */
+	  callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+	  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
+				       NULL_TREE, false, !comp->attr.pointer,
+				       callee_alloc, &se->ss->expr->where);
+
+	  /* Pass the temporary as the first argument.  */
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
+	  retargs = gfc_chainon_list (retargs, tmp);
+	}
+      else if (!comp && sym->result->attr.dimension)
 	{
 	  gcc_assert (se->loop && info);
 
@@ -2892,22 +3391,29 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 				       callee_alloc, &se->ss->expr->where);
 
 	  /* Pass the temporary as the first argument.  */
-	  tmp = info->descriptor;
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
 	  retargs = gfc_chainon_list (retargs, tmp);
 	}
       else if (ts.type == BT_CHARACTER)
 	{
 	  /* Pass the string length.  */
-	  type = gfc_get_character_type (ts.kind, ts.cl);
+	  type = gfc_get_character_type (ts.kind, ts.u.cl);
 	  type = build_pointer_type (type);
 
 	  /* Return an address to a char[0:len-1]* temporary for
 	     character pointers.  */
-	  if (sym->attr.pointer || sym->attr.allocatable)
+	  if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+	       || (comp && (comp->attr.pointer || comp->attr.allocatable)))
 	    {
 	      var = gfc_create_var (type, "pstr");
 
+	      if ((!comp && sym->attr.allocatable)
+		  || (comp && comp->attr.allocatable))
+		gfc_add_modify (&se->pre, var,
+				fold_convert (TREE_TYPE (var),
+					      null_pointer_node));
+
 	      /* Provide an address expression for the function arguments.  */
 	      var = gfc_build_addr_expr (NULL_TREE, var);
 	    }
@@ -2943,7 +3449,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
     arglist = chainon (arglist, append_args);
 
   /* Generate the actual call.  */
-  gfc_conv_function_val (se, sym);
+  conv_function_val (se, sym, expr);
 
   /* If there are alternate return labels, function type should be
      integer.  Can't modify the type in place though, since it can be shared
@@ -2970,8 +3476,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
      something like
         x = f()
      where f is pointer valued, we have to dereference the result.  */
-  if (!se->want_pointer && !byref && sym->attr.pointer)
-    se->expr = build_fold_indirect_ref (se->expr);
+  if (!se->want_pointer && !byref
+      && (sym->attr.pointer || sym->attr.allocatable)
+      && !gfc_is_proc_ptr_comp (expr, NULL))
+    se->expr = build_fold_indirect_ref_loc (input_location,
+					se->expr);
 
   /* f2c calling conventions require a scalar default real function to
      return a double precision result.  Convert this back to default
@@ -2998,7 +3507,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 
       if (!se->direct_byref)
 	{
-	  if (sym->attr.dimension)
+	  if (sym->attr.dimension || (comp && comp->attr.dimension))
 	    {
 	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 		{
@@ -3014,11 +3523,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
 	    }
-	  else if (sym->ts.type == BT_CHARACTER)
+	  else if (ts.type == BT_CHARACTER)
 	    {
 	      /* Dereference for character pointer results.  */
-	      if (sym->attr.pointer || sym->attr.allocatable)
-		se->expr = build_fold_indirect_ref (var);
+	      if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+		  || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+		se->expr = build_fold_indirect_ref_loc (input_location, var);
 	      else
 	        se->expr = var;
 
@@ -3026,15 +3536,44 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else
 	    {
-	      gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
-	      se->expr = build_fold_indirect_ref (var);
+	      gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+	      se->expr = build_fold_indirect_ref_loc (input_location, var);
 	    }
 	}
     }
 
   /* Follow the function call with the argument post block.  */
   if (byref)
-    gfc_add_block_to_block (&se->pre, &post);
+    {
+      gfc_add_block_to_block (&se->pre, &post);
+
+      /* Transformational functions of derived types with allocatable
+         components must have the result allocatable components copied.  */
+      arg = expr->value.function.actual;
+      if (result && arg && expr->rank
+	    && expr->value.function.isym
+	    && expr->value.function.isym->transformational
+	    && arg->expr->ts.type == BT_DERIVED
+	    && arg->expr->ts.u.derived->attr.alloc_comp)
+	{
+	  tree tmp2;
+	  /* Copy the allocatable components.  We have to use a
+	     temporary here to prevent source allocatable components
+	     from being corrupted.  */
+	  tmp2 = gfc_evaluate_now (result, &se->pre);
+	  tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+				     result, tmp2, expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	  tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+				           expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+
+	  /* Finally free the temporary's data field.  */
+	  tmp = gfc_conv_descriptor_data_get (tmp2);
+	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+    }
   else
     gfc_add_block_to_block (&se->post, &post);
 
@@ -3052,7 +3591,8 @@ fill_with_spaces (tree start, tree type, tree size)
 
   /* For a simple char type, we can call memset().  */
   if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
-    return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+    return build_call_expr_loc (input_location,
+			    built_in_decls[BUILT_IN_MEMSET], 3, start,
 			    build_int_cst (gfc_get_int_type (gfc_c_int_kind),
 					   lang_hooks.to_target_charset (' ')),
 			    size);
@@ -3079,7 +3619,8 @@ fill_with_spaces (tree start, tree type, tree size)
   cond = fold_build2 (LE_EXPR, boolean_type_node, i,
 		      fold_convert (sizetype, integer_zero_node));
   tmp = build1_v (GOTO_EXPR, exit_label);
-  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+		     build_empty_stmt (input_location));
   gfc_add_expr_to_block (&loop, tmp);
 
   /* Assignment.  */
@@ -3212,11 +3753,13 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
 
   /* Truncate string if source is too long.  */
   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
-  tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+  tmp2 = build_call_expr_loc (input_location,
+			  built_in_decls[BUILT_IN_MEMMOVE],
 			  3, dest, src, dlen);
 
   /* Else copy and pad with spaces.  */
-  tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+  tmp3 = build_call_expr_loc (input_location,
+			  built_in_decls[BUILT_IN_MEMMOVE],
 			  3, dest, src, slen);
 
   tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
@@ -3232,7 +3775,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
 
   /* The whole copy_string function is there.  */
   tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
-  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+		     build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
 }
 
@@ -3284,8 +3828,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 	  /* Copy string arguments.  */
           tree arglen;
 
-          gcc_assert (fsym->ts.cl && fsym->ts.cl->length
-		      && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+          gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+		      && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
 
           arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
           tmp = gfc_build_addr_expr (build_pointer_type (type),
@@ -3322,22 +3866,22 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 
   if (sym->ts.type == BT_CHARACTER)
     {
-      gfc_conv_const_charlen (sym->ts.cl);
+      gfc_conv_const_charlen (sym->ts.u.cl);
 
       /* Force the expression to the correct length.  */
       if (!INTEGER_CST_P (se->string_length)
 	  || tree_int_cst_lt (se->string_length,
-			      sym->ts.cl->backend_decl))
+			      sym->ts.u.cl->backend_decl))
 	{
-	  type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+	  type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
 	  tmp = gfc_create_var (type, sym->name);
 	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
-	  gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+	  gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
 				 sym->ts.kind, se->string_length, se->expr,
 				 sym->ts.kind);
 	  se->expr = tmp;
 	}
-      se->string_length = sym->ts.cl->backend_decl;
+      se->string_length = sym->ts.u.cl->backend_decl;
     }
 
   /* Restore the original variables.  */
@@ -3373,7 +3917,46 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
   sym = expr->value.function.esym;
   if (!sym)
     sym = expr->symtree->n.sym;
-  gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
+
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  NULL_TREE);
+}
+
+
+/* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
+
+static bool
+is_zero_initializer_p (gfc_expr * expr)
+{
+  if (expr->expr_type != EXPR_CONSTANT)
+    return false;
+
+  /* We ignore constants with prescribed memory representations for now.  */
+  if (expr->representation.string)
+    return false;
+
+  switch (expr->ts.type)
+    {
+    case BT_INTEGER:
+      return mpz_cmp_si (expr->value.integer, 0) == 0;
+
+    case BT_REAL:
+      return mpfr_zero_p (expr->value.real)
+	     && MPFR_SIGN (expr->value.real) >= 0;
+
+    case BT_LOGICAL:
+      return expr->value.logical == 0;
+
+    case BT_COMPLEX:
+      return mpfr_zero_p (mpc_realref (expr->value.complex))
+	     && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
+             && mpfr_zero_p (mpc_imagref (expr->value.complex))
+	     && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
+
+    default:
+      break;
+    }
+  return false;
 }
 
 
@@ -3406,16 +3989,18 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
      used as initialization expressions).  If so, we need to modify
      the 'expr' to be that for a (void *).  */
   if (expr != NULL && expr->ts.type == BT_DERIVED
-      && expr->ts.is_iso_c && expr->ts.derived)
+      && expr->ts.is_iso_c && expr->ts.u.derived)
     {
-      gfc_symbol *derived = expr->ts.derived;
-
-      expr = gfc_int_expr (0);
+      gfc_symbol *derived = expr->ts.u.derived;
 
       /* The derived symbol has already been converted to a (void *).  Use
 	 its kind.  */
+      expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
       expr->ts.f90_type = derived->ts.f90_type;
-      expr->ts.kind = derived->ts.kind;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_constant (&se, expr);
+      return se.expr;
     }
   
   if (array)
@@ -3423,6 +4008,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
       /* Arrays need special handling.  */
       if (pointer)
 	return gfc_build_null_descriptor (type);
+      /* Special case assigning an array to zero.  */
+      else if (is_zero_initializer_p (expr))
+        return build_constructor (type, NULL);
       else
 	return gfc_conv_array_initializer (type, expr);
     }
@@ -3433,12 +4021,13 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
       switch (ts->type)
 	{
 	case BT_DERIVED:
+	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
 	  gfc_conv_structure (&se, expr, 1);
 	  return se.expr;
 
 	case BT_CHARACTER:
-	  return gfc_conv_string_init (ts->cl->backend_decl,expr);
+	  return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
 
 	default:
 	  gfc_init_se (&se, NULL);
@@ -3526,11 +4115,11 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
   gfc_conv_tmp_array_ref (&lse);
   if (cm->ts.type == BT_CHARACTER)
-    lse.string_length = cm->ts.cl->backend_decl;
+    lse.string_length = cm->ts.u.cl->backend_decl;
 
   gfc_conv_expr (&rse, expr);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
   gfc_add_expr_to_block (&body, tmp);
 
   gcc_assert (rse.ss == gfc_ss_terminator);
@@ -3552,6 +4141,149 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 }
 
 
+static tree
+gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
+				 gfc_expr * expr)
+{
+  gfc_se se;
+  gfc_ss *rss;
+  stmtblock_t block;
+  tree offset;
+  int n;
+  tree tmp;
+  tree tmp2;
+  gfc_array_spec *as;
+  gfc_expr *arg = NULL;
+
+  gfc_start_block (&block);
+  gfc_init_se (&se, NULL);
+
+  /* Get the descriptor for the expressions.  */ 
+  rss = gfc_walk_expr (expr);
+  se.want_pointer = 0;
+  gfc_conv_expr_descriptor (&se, expr, rss);
+  gfc_add_block_to_block (&block, &se.pre);
+  gfc_add_modify (&block, dest, se.expr);
+
+  /* Deal with arrays of derived types with allocatable components.  */
+  if (cm->ts.type == BT_DERIVED
+	&& cm->ts.u.derived->attr.alloc_comp)
+    tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
+			       se.expr, dest,
+			       cm->as->rank);
+  else
+    tmp = gfc_duplicate_allocatable (dest, se.expr,
+				     TREE_TYPE(cm->backend_decl),
+				     cm->as->rank);
+
+  gfc_add_expr_to_block (&block, tmp);
+  gfc_add_block_to_block (&block, &se.post);
+
+  if (expr->expr_type != EXPR_VARIABLE)
+    gfc_conv_descriptor_data_set (&block, se.expr,
+				  null_pointer_node);
+
+  /* We need to know if the argument of a conversion function is a
+     variable, so that the correct lower bound can be used.  */
+  if (expr->expr_type == EXPR_FUNCTION
+	&& expr->value.function.isym
+	&& expr->value.function.isym->conversion
+	&& expr->value.function.actual->expr
+	&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+    arg = expr->value.function.actual->expr;
+
+  /* Obtain the array spec of full array references.  */
+  if (arg)
+    as = gfc_get_full_arrayspec_from_expr (arg);
+  else
+    as = gfc_get_full_arrayspec_from_expr (expr);
+
+  /* Shift the lbound and ubound of temporaries to being unity,
+     rather than zero, based. Always calculate the offset.  */
+  offset = gfc_conv_descriptor_offset_get (dest);
+  gfc_add_modify (&block, offset, gfc_index_zero_node);
+  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+
+  for (n = 0; n < expr->rank; n++)
+    {
+      tree span;
+      tree lbound;
+
+      /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+	 TODO It looks as if gfc_conv_expr_descriptor should return
+	 the correct bounds and that the following should not be
+	 necessary.  This would simplify gfc_conv_intrinsic_bound
+	 as well.  */
+      if (as && as->lower[n])
+	{
+	  gfc_se lbse;
+	  gfc_init_se (&lbse, NULL);
+	  gfc_conv_expr (&lbse, as->lower[n]);
+	  gfc_add_block_to_block (&block, &lbse.pre);
+	  lbound = gfc_evaluate_now (lbse.expr, &block);
+	}
+      else if (as && arg)
+	{
+	  tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
+	  lbound = gfc_conv_descriptor_lbound_get (tmp,
+					gfc_rank_cst[n]);
+	}
+      else if (as)
+	lbound = gfc_conv_descriptor_lbound_get (dest,
+						gfc_rank_cst[n]);
+      else
+	lbound = gfc_index_one_node;
+
+      lbound = fold_convert (gfc_array_index_type, lbound);
+
+      /* Shift the bounds and set the offset accordingly.  */
+      tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
+      span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
+		gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
+      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
+      gfc_conv_descriptor_ubound_set (&block, dest,
+				      gfc_rank_cst[n], tmp);
+      gfc_conv_descriptor_lbound_set (&block, dest,
+				      gfc_rank_cst[n], lbound);
+
+      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			 gfc_conv_descriptor_lbound_get (dest,
+							 gfc_rank_cst[n]),
+			 gfc_conv_descriptor_stride_get (dest,
+							 gfc_rank_cst[n]));
+      gfc_add_modify (&block, tmp2, tmp);
+      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+      gfc_conv_descriptor_offset_set (&block, dest, tmp);
+    }
+
+  if (arg)
+    {
+      /* If a conversion expression has a null data pointer
+	 argument, nullify the allocatable component.  */
+      tree non_null_expr;
+      tree null_expr;
+
+      if (arg->symtree->n.sym->attr.allocatable
+	    || arg->symtree->n.sym->attr.pointer)
+	{
+	  non_null_expr = gfc_finish_block (&block);
+	  gfc_start_block (&block);
+	  gfc_conv_descriptor_data_set (&block, dest,
+					null_pointer_node);
+	  null_expr = gfc_finish_block (&block);
+	  tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
+	  tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
+			fold_convert (TREE_TYPE (tmp),
+				      null_pointer_node));
+	  return build3_v (COND_EXPR, tmp,
+			   null_expr, non_null_expr);
+	}
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Assign a single component of a derived type constructor.  */
 
 static tree
@@ -3562,8 +4294,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   gfc_ss *rss;
   stmtblock_t block;
   tree tmp;
-  tree offset;
-  int n;
 
   gfc_start_block (&block);
 
@@ -3597,97 +4327,21 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 	  gfc_add_block_to_block (&block, &se.post);
 	}
     }
+  else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
+    {
+      /* NULL initialization for CLASS components.  */
+      tmp = gfc_trans_structure_assign (dest,
+					gfc_default_initializer (&cm->ts));
+      gfc_add_expr_to_block (&block, tmp);
+    }
   else if (cm->attr.dimension)
     {
       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
  	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
       else if (cm->attr.allocatable)
 	{
-	  tree tmp2;
-
-          gfc_init_se (&se, NULL);
- 
-	  rss = gfc_walk_expr (expr);
-	  se.want_pointer = 0;
-	  gfc_conv_expr_descriptor (&se, expr, rss);
-	  gfc_add_block_to_block (&block, &se.pre);
-
-	  tmp = fold_convert (TREE_TYPE (dest), se.expr);
-	  gfc_add_modify (&block, dest, tmp);
-
-	  if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
-	    tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
-				       cm->as->rank);
-	  else
-	    tmp = gfc_duplicate_allocatable (dest, se.expr,
-					     TREE_TYPE(cm->backend_decl),
-					     cm->as->rank);
-
+	  tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
 	  gfc_add_expr_to_block (&block, tmp);
-	  gfc_add_block_to_block (&block, &se.post);
-
-	  if (expr->expr_type != EXPR_VARIABLE)
-	    gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
-
-	  /* Shift the lbound and ubound of temporaries to being unity, rather
-	     than zero, based.  Calculate the offset for all cases.  */
-	  offset = gfc_conv_descriptor_offset (dest);
-	  gfc_add_modify (&block, offset, gfc_index_zero_node);
-	  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
-	  for (n = 0; n < expr->rank; n++)
-	    {
-	      if (expr->expr_type != EXPR_VARIABLE
-		    && expr->expr_type != EXPR_CONSTANT)
-		{
-		  tree span;
-		  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
-		  span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
-			    gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
-		  gfc_add_modify (&block, tmp,
-				       fold_build2 (PLUS_EXPR,
-						    gfc_array_index_type,
-						    span, gfc_index_one_node));
-		  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
-		  gfc_add_modify (&block, tmp, gfc_index_one_node);
-		}
-	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
-				 gfc_conv_descriptor_lbound (dest,
-							     gfc_rank_cst[n]),
-				 gfc_conv_descriptor_stride (dest,
-							     gfc_rank_cst[n]));
-	      gfc_add_modify (&block, tmp2, tmp);
-	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
-	      gfc_add_modify (&block, offset, tmp);
-	    }
-
-	  if (expr->expr_type == EXPR_FUNCTION
-		&& expr->value.function.isym
-		&& expr->value.function.isym->conversion
-		&& expr->value.function.actual->expr
-		&& expr->value.function.actual->expr->expr_type
-						== EXPR_VARIABLE)
-	    {
-	      /* If a conversion expression has a null data pointer
-		 argument, nullify the allocatable component.  */
-	      gfc_symbol *s;
-	      tree non_null_expr;
-	      tree null_expr;
-	      s = expr->value.function.actual->expr->symtree->n.sym;
-	      if (s->attr.allocatable || s->attr.pointer)
-		{
-		  non_null_expr = gfc_finish_block (&block);
-		  gfc_start_block (&block);
-		  gfc_conv_descriptor_data_set (&block, dest,
-						null_pointer_node);
-		  null_expr = gfc_finish_block (&block);
-		  tmp = gfc_conv_descriptor_data_get (s->backend_decl);
-		  tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
-			        fold_convert (TREE_TYPE (tmp),
-					      null_pointer_node));
-		  return build3_v (COND_EXPR, tmp, null_expr,
-				   non_null_expr);
-		}
-	    }
 	}
       else
 	{
@@ -3721,9 +4375,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
       gfc_conv_expr (&se, expr);
       if (cm->ts.type == BT_CHARACTER)
-	lse.string_length = cm->ts.cl->backend_decl;
+	lse.string_length = cm->ts.u.cl->backend_decl;
       lse.expr = dest;
-      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
       gfc_add_expr_to_block (&block, tmp);
     }
   return gfc_finish_block (&block);
@@ -3741,13 +4395,27 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
   tree tmp;
 
   gfc_start_block (&block);
-  cm = expr->ts.derived->components;
-  for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+  cm = expr->ts.u.derived->components;
+  for (c = gfc_constructor_first (expr->value.constructor);
+       c; c = gfc_constructor_next (c), cm = cm->next)
     {
       /* Skip absent members in default initializers.  */
       if (!c->expr)
 	continue;
 
+      /* Handle c_null_(fun)ptr.  */
+      if (c && c->expr && c->expr->ts.is_iso_c)
+	{
+	  field = cm->backend_decl;
+	  tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+			     dest, field, NULL_TREE);
+	  tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+			     fold_convert (TREE_TYPE (tmp),
+					   null_pointer_node));
+	  gfc_add_expr_to_block (&block, tmp);
+	  continue;
+	}
+
       field = cm->backend_decl;
       tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 			 dest, field, NULL_TREE);
@@ -3777,15 +4445,16 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
   if (!init)
     {
       /* Create a temporary variable and fill it in.  */
-      se->expr = gfc_create_var (type, expr->ts.derived->name);
+      se->expr = gfc_create_var (type, expr->ts.u.derived->name);
       tmp = gfc_trans_structure_assign (se->expr, expr);
       gfc_add_expr_to_block (&se->pre, tmp);
       return;
     }
 
-  cm = expr->ts.derived->components;
+  cm = expr->ts.u.derived->components;
 
-  for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+  for (c = gfc_constructor_first (expr->value.constructor);
+       c; c = gfc_constructor_next (c), cm = cm->next)
     {
       /* Skip absent members in default initializers and allocatable
 	 components.  Although the latter have a default initializer
@@ -3794,11 +4463,41 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      val = gfc_conv_initializer (c->expr, &cm->ts,
-	  TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
+      if (cm->ts.type == BT_CLASS)
+	{
+	  gfc_component *data;
+	  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
+	  if (!data->backend_decl)
+	    gfc_get_derived_type (cm->ts.u.derived);
+	  val = gfc_conv_initializer (c->expr, &cm->ts,
+				      TREE_TYPE (data->backend_decl),
+				      data->attr.dimension,
+				      data->attr.pointer);
+
+	  CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+	}
+      else if (strcmp (cm->name, "$size") == 0)
+	{
+	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+      else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+	       && strcmp (cm->name, "$extends") == 0)
+	{
+	  gfc_symbol *vtabs;
+	  vtabs = cm->initializer->symtree->n.sym;
+	  val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
+      else
+	{
+	  val = gfc_conv_initializer (c->expr, &cm->ts,
+	      TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+	      cm->attr.pointer || cm->attr.proc_pointer);
 
-      /* Append it to the constructor list.  */
-      CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	  /* Append it to the constructor list.  */
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
     }
   se->expr = build_constructor (type, v);
   if (init) 
@@ -3852,8 +4551,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
      null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
      typespec for the C_PTR and C_FUNPTR symbols, which has already been
      updated to be an integer with a kind equal to the size of a (void *).  */
-  if (expr->ts.type == BT_DERIVED && expr->ts.derived
-      && expr->ts.derived->attr.is_iso_c)
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+      && expr->ts.u.derived->attr.is_iso_c)
     {
       if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
           || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
@@ -3866,9 +4565,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
         {
           /* Update the type/kind of the expression to be what the new
              type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
-          expr->ts.type = expr->ts.derived->ts.type;
-          expr->ts.f90_type = expr->ts.derived->ts.f90_type;
-          expr->ts.kind = expr->ts.derived->ts.kind;
+          expr->ts.type = expr->ts.u.derived->ts.type;
+          expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
+          expr->ts.kind = expr->ts.u.derived->ts.kind;
         }
     }
   
@@ -3990,8 +4689,12 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
     }
 
   if (expr->expr_type == EXPR_FUNCTION
-	&& expr->symtree->n.sym->attr.pointer
-	&& !expr->symtree->n.sym->attr.dimension)
+      && ((expr->value.function.esym
+	   && expr->value.function.esym->result->attr.pointer
+	   && !expr->value.function.esym->result->attr.dimension)
+	  || (!expr->value.function.esym
+	      && expr->symtree->n.sym->attr.pointer
+	      && !expr->symtree->n.sym->attr.dimension)))
     {
       se->want_pointer = 1;
       gfc_conv_expr (se, expr);
@@ -4009,7 +4712,8 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
     {
       tree tmp = se->expr;
       STRIP_TYPE_NOPS (tmp);
-      var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
+      var = build_decl (input_location,
+			CONST_DECL, NULL, TREE_TYPE (tmp));
       DECL_INITIAL (var) = tmp;
       TREE_STATIC (var) = 1;
       pushdecl (var);
@@ -4029,7 +4733,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
-  return gfc_trans_pointer_assignment (code->expr, code->expr2);
+  return gfc_trans_pointer_assignment (code->expr1, code->expr2);
 }
 
 
@@ -4065,14 +4769,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       if (expr1->symtree->n.sym->attr.proc_pointer
 	  && expr1->symtree->n.sym->attr.dummy)
-	lse.expr = build_fold_indirect_ref (lse.expr);
+	lse.expr = build_fold_indirect_ref_loc (input_location,
+					    lse.expr);
+
+      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+	  && expr2->symtree->n.sym->attr.dummy)
+	rse.expr = build_fold_indirect_ref_loc (input_location,
+					    rse.expr);
 
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
       /* Check character lengths if character expression.  The test is only
 	 really added if -fbounds-check is enabled.  */
-      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+	  && !expr1->symtree->n.sym->attr.proc_pointer
+	  && !gfc_is_proc_ptr_comp (expr1, NULL))
 	{
 	  gcc_assert (expr2->ts.type == BT_CHARACTER);
 	  gcc_assert (lse.string_length && rse.string_length);
@@ -4195,11 +4907,12 @@ gfc_conv_string_parameter (gfc_se * se)
 
 
 /* Generate code for assignment of scalar variables.  Includes character
-   strings and derived types with allocatable components.  */
+   strings and derived types with allocatable components.
+   If you know that the LHS has no allocations, set dealloc to false.  */
 
 tree
 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
-			 bool l_is_temp, bool r_is_var)
+			 bool l_is_temp, bool r_is_var, bool dealloc)
 {
   stmtblock_t block;
   tree tmp;
@@ -4230,7 +4943,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
 			     rse->expr, ts.kind);
     }
-  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+  else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
       cond = NULL_TREE;
 	
@@ -4247,12 +4960,13 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	 the same as the rhs.  This must be done following the assignment
 	 to prevent deallocating data that could be used in the rhs
 	 expression.  */
-      if (!l_is_temp)
+      if (!l_is_temp && dealloc)
 	{
 	  tmp = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
+	  tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
 	  if (r_is_var)
-	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			    tmp);
 	  gfc_add_expr_to_block (&lse->post, tmp);
 	}
 
@@ -4266,18 +4980,26 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	 same as the lhs.  */
       if (r_is_var)
 	{
-	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
-	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			  tmp);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
+  else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+    {
+      gfc_add_block_to_block (&block, &lse->pre);
+      gfc_add_block_to_block (&block, &rse->pre);
+      tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
+      gfc_add_modify (&block, lse->expr, tmp);
+    }
   else
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
 
       gfc_add_modify (&block, lse->expr,
-			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
     }
 
   gfc_add_block_to_block (&block, &lse->post);
@@ -4298,6 +5020,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
+  bool c = false;
+  gfc_component *comp = NULL;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -4308,6 +5032,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
       && expr2->value.function.esym->attr.elemental)
     return NULL;
 
+  /* Fail if rhs is not FULL or a contiguous section.  */
+  if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
+    return NULL;
+
   /* Fail if EXPR1 can't be expressed as a descriptor.  */
   if (gfc_ref_needs_temporary_p (expr1->ref))
     return NULL;
@@ -4321,16 +5049,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
      character lengths are the same.  */
   if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
     {
-      if (expr1->ts.cl->length == NULL
-	    || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
+      if (expr1->ts.u.cl->length == NULL
+	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 	return NULL;
 
-      if (expr2->ts.cl->length == NULL
-	    || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
+      if (expr2->ts.u.cl->length == NULL
+	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 	return NULL;
 
-      if (mpz_cmp (expr1->ts.cl->length->value.integer,
-		     expr2->ts.cl->length->value.integer) != 0)
+      if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
+		     expr2->ts.u.cl->length->value.integer) != 0)
 	return NULL;
     }
 
@@ -4358,8 +5086,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
   gcc_assert (expr2->value.function.isym
-	      || (gfc_return_by_reference (expr2->value.function.esym)
-	      && expr2->value.function.esym->result->attr.dimension));
+	      || (gfc_is_proc_ptr_comp (expr2, &comp)
+		  && comp && comp->attr.dimension)
+	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
+		  && expr2->value.function.esym->result->attr.dimension));
 
   ss = gfc_walk_expr (expr1);
   gcc_assert (ss != gfc_ss_terminator);
@@ -4367,7 +5097,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
-  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
+
+  if (expr1->ts.type == BT_DERIVED
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tree tmp;
+      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+				       expr1->rank);
+      gfc_add_expr_to_block (&se.pre, tmp);
+    }
 
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
@@ -4378,41 +5117,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   return gfc_finish_block (&se.pre);
 }
 
-/* Determine whether the given EXPR_CONSTANT is a zero initializer.  */
-
-static bool
-is_zero_initializer_p (gfc_expr * expr)
-{
-  if (expr->expr_type != EXPR_CONSTANT)
-    return false;
-
-  /* We ignore constants with prescribed memory representations for now.  */
-  if (expr->representation.string)
-    return false;
-
-  switch (expr->ts.type)
-    {
-    case BT_INTEGER:
-      return mpz_cmp_si (expr->value.integer, 0) == 0;
-
-    case BT_REAL:
-      return mpfr_zero_p (expr->value.real)
-	     && MPFR_SIGN (expr->value.real) >= 0;
-
-    case BT_LOGICAL:
-      return expr->value.logical == 0;
-
-    case BT_COMPLEX:
-      return mpfr_zero_p (expr->value.complex.r)
-	     && MPFR_SIGN (expr->value.complex.r) >= 0
-             && mpfr_zero_p (expr->value.complex.i)
-	     && MPFR_SIGN (expr->value.complex.i) >= 0;
-
-    default:
-      break;
-    }
-  return false;
-}
 
 /* Try to efficiently translate array(:) = 0.  Return NULL if this
    can't be done.  */
@@ -4442,15 +5146,19 @@ gfc_trans_zero_assign (gfc_expr * expr)
   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
 		     fold_convert (gfc_array_index_type, tmp));
 
-  /* Convert arguments to the correct types.  */
+  /* If we are zeroing a local array avoid taking its address by emitting
+     a = {} instead.  */
   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
-    dest = gfc_build_addr_expr (pvoid_type_node, dest);
-  else
-    dest = fold_convert (pvoid_type_node, dest);
+    return build2 (MODIFY_EXPR, void_type_node,
+		   dest, build_constructor (TREE_TYPE (dest), NULL));
+
+  /* Convert arguments to the correct types.  */
+  dest = fold_convert (pvoid_type_node, dest);
   len = fold_convert (size_type_node, len);
 
   /* Construct call to __builtin_memset.  */
-  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
+  tmp = build_call_expr_loc (input_location,
+			 built_in_decls[BUILT_IN_MEMSET],
 			 3, dest, integer_zero_node, len);
   return fold_convert (void_type_node, tmp);
 }
@@ -4478,7 +5186,8 @@ gfc_build_memcpy_call (tree dst, tree src, tree len)
   len = fold_convert (size_type_node, len);
 
   /* Construct call to __builtin_memcpy.  */
-  tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+  tmp = build_call_expr_loc (input_location,
+			 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
   return fold_convert (void_type_node, tmp);
 }
 
@@ -4581,10 +5290,13 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
 
 
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
-   assignment.  EXPR1 is the destination/RHS and EXPR2 is the source/LHS.  */
+   assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+   init_flag indicates initialization expressions and dealloc that no
+   deallocate prior assignment is needed (if in doubt, set true).  */
 
 static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+			bool dealloc)
 {
   gfc_se lse;
   gfc_se rse;
@@ -4697,20 +5409,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
      to arrays must be done with a deep copy and the rhs temporary
      must have its components deallocated afterwards.  */
   scalar_to_array = (expr2->ts.type == BT_DERIVED
-		       && expr2->ts.derived->attr.alloc_comp
+		       && expr2->ts.u.derived->attr.alloc_comp
 		       && expr2->expr_type != EXPR_VARIABLE
 		       && !gfc_is_constant_expr (expr2)
 		       && expr1->rank && !expr2->rank);
-  if (scalar_to_array)
+  if (scalar_to_array && dealloc)
     {
-      tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+      tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
       gfc_add_expr_to_block (&loop.post, tmp);
     }
 
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
 				 l_is_temp || init_flag,
 				 (expr2->expr_type == EXPR_VARIABLE)
-				    || scalar_to_array);
+				    || scalar_to_array, dealloc);
   gfc_add_expr_to_block (&body, tmp);
 
   if (lss == gfc_ss_terminator)
@@ -4747,7 +5459,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
 	    rse.string_length = string_length;
 
 	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-					 false, false);
+					 false, false, dealloc);
 	  gfc_add_expr_to_block (&body, tmp);
 	}
 
@@ -4777,7 +5489,7 @@ copyable_array_p (gfc_expr * expr)
   if (expr->rank < 1 || !expr->ref || expr->ref->next)
     return false;
 
-  if (!gfc_full_array_ref_p (expr->ref))
+  if (!gfc_full_array_ref_p (expr->ref, NULL))
     return false;
 
   /* Next check that it's of a simple enough type.  */
@@ -4793,7 +5505,7 @@ copyable_array_p (gfc_expr * expr)
       return false;
 
     case BT_DERIVED:
-      return !expr->ts.derived->attr.alloc_comp;
+      return !expr->ts.u.derived->attr.alloc_comp;
 
     default:
       break;
@@ -4805,7 +5517,8 @@ copyable_array_p (gfc_expr * expr)
 /* Translate an assignment.  */
 
 tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+		      bool dealloc)
 {
   tree tmp;
 
@@ -4848,17 +5561,98 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
     }
 
   /* Fallback to the scalarizer to generate explicit loops.  */
-  return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
 }
 
 tree
 gfc_trans_init_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr, code->expr2, true);
+  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
 }
 
 tree
 gfc_trans_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr, code->expr2, false);
+  return gfc_trans_assignment (code->expr1, code->expr2, false, true);
+}
+
+
+/* Translate an assignment to a CLASS object
+   (pointer or ordinary assignment).  */
+
+tree
+gfc_trans_class_assign (gfc_code *code)
+{
+  stmtblock_t block;
+  tree tmp;
+  gfc_expr *lhs;
+  gfc_expr *rhs;
+
+  gfc_start_block (&block);
+  
+  if (code->op == EXEC_INIT_ASSIGN)
+    {
+      /* Special case for initializing a CLASS variable on allocation.
+	 A MEMCPY is needed to copy the full data of the dynamic type,
+	 which may be different from the declared type.  */
+      gfc_se dst,src;
+      tree memsz;
+      gfc_init_se (&dst, NULL);
+      gfc_init_se (&src, NULL);
+      gfc_add_component_ref (code->expr1, "$data");
+      gfc_conv_expr (&dst, code->expr1);
+      gfc_conv_expr (&src, code->expr2);
+      gfc_add_block_to_block (&block, &src.pre);
+      memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+      gfc_add_expr_to_block (&block, tmp);
+      return gfc_finish_block (&block);
+    }
+
+  if (code->expr2->ts.type != BT_CLASS)
+    {
+      /* Insert an additional assignment which sets the '$vptr' field.  */
+      lhs = gfc_copy_expr (code->expr1);
+      gfc_add_component_ref (lhs, "$vptr");
+      if (code->expr2->ts.type == BT_DERIVED)
+	{
+	  gfc_symbol *vtab;
+	  gfc_symtree *st;
+	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  gcc_assert (vtab);
+
+	  rhs = gfc_get_expr ();
+	  rhs->expr_type = EXPR_VARIABLE;
+	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+	  rhs->symtree = st;
+	  rhs->ts = vtab->ts;
+	}
+      else if (code->expr2->expr_type == EXPR_NULL)
+	rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+      else
+	gcc_unreachable ();
+
+      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+      gfc_add_expr_to_block (&block, tmp);
+
+      gfc_free_expr (lhs);
+      gfc_free_expr (rhs);
+    }
+
+  /* Do the actual CLASS assignment.  */
+  if (code->expr2->ts.type == BT_CLASS)
+    code->op = EXEC_ASSIGN;
+  else
+    gfc_add_component_ref (code->expr1, "$data");
+
+  if (code->op == EXEC_ASSIGN)
+    tmp = gfc_trans_assign (code);
+  else if (code->op == EXEC_POINTER_ASSIGN)
+    tmp = gfc_trans_pointer_assign (code);
+  else
+    gcc_unreachable();
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
 }