OSDN Git Service

* trans.h (struct gfc_ss, struct gfc_ss_info): Move field
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c
index 72a7c2c..01d4ca3 100644 (file)
@@ -1,5 +1,6 @@
 /* Expression translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -260,6 +261,33 @@ gfc_get_expr_charlen (gfc_expr *e)
 }
 
 
+/* Return for an expression the backend decl of the coarray.  */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+   tree caf_decl = NULL_TREE;
+   gfc_ref *ref;
+
+   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+   if (expr->symtree->n.sym->attr.codimension)
+     caf_decl = expr->symtree->n.sym->backend_decl;
+
+   for (ref = expr->ref; ref; ref = ref->next)
+     if (ref->type == REF_COMPONENT)
+       {
+       gfc_component *comp = ref->u.c.component;
+        if (comp->attr.pointer || comp->attr.allocatable)
+         caf_decl = NULL_TREE;
+       if (comp->attr.codimension)
+         caf_decl = comp->backend_decl;
+       }
+
+   gcc_assert (caf_decl != NULL_TREE);
+   return caf_decl;
+}
+
+
 /* 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).  */
@@ -448,7 +476,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node,
                                             start.expr));
-      gfc_free (msg);
+      free (msg);
 
       /* Check upper bound.  */
       fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
@@ -465,7 +493,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
                               fold_convert (long_integer_type_node, end.expr),
                               fold_convert (long_integer_type_node,
                                             se->string_length));
-      gfc_free (msg);
+      free (msg);
     }
 
   /* If the start and end expressions are equal, the length is one.  */
@@ -503,6 +531,26 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
   field = c->backend_decl;
   gcc_assert (TREE_CODE (field) == FIELD_DECL);
   decl = se->expr;
+
+  /* Components can correspond to fields of different containing
+     types, as components are created without context, whereas
+     a concrete use of a component has the type of decl as context.
+     So, if the type doesn't match, we search the corresponding
+     FIELD_DECL in the parent type.  To not waste too much time
+     we cache this result in norestrict_decl.  */
+
+  if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+    {
+      tree f2 = c->norestrict_decl;
+      if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+       for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+         if (TREE_CODE (f2) == FIELD_DECL
+             && DECL_NAME (f2) == DECL_NAME (field))
+           break;
+      gcc_assert (f2);
+      c->norestrict_decl = f2;
+      field = f2;
+    }
   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
                         decl, field, NULL_TREE);
 
@@ -516,7 +564,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       se->string_length = tmp;
     }
 
-  if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+  if (((c->attr.pointer || c->attr.allocatable)
+       && (!c->attr.dimension && !c->attr.codimension)
        && c->ts.type != BT_CHARACTER)
       || c->attr.proc_pointer)
     se->expr = build_fold_indirect_ref_loc (input_location,
@@ -537,6 +586,11 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
   dt = ref->u.c.sym;
   c = ref->u.c.component;
 
+  /* Return if the component is not in the parent type.  */
+  for (cmp = dt->components; cmp; cmp = cmp->next)
+    if (strcmp (c->name, cmp->name) == 0)
+      return;
+
   /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
   parent.type = REF_COMPONENT;
   parent.next = NULL;
@@ -546,23 +600,11 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
   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; 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.u.derived;
-      parent.u.c.component = c;
-      conv_parent_component_references (se, &parent);
-    }
+  /* Build the reference and call self.  */
+  gfc_conv_component_ref (se, &parent);
+  parent.u.c.sym = dt->components->ts.u.derived;
+  parent.u.c.component = c;
+  conv_parent_component_references (se, &parent);
 }
 
 /* Return the contents of a variable. Also handles reference/pointer
@@ -571,6 +613,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
 static void
 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 {
+  gfc_ss *ss;
   gfc_ref *ref;
   gfc_symbol *sym;
   tree parent_decl = NULL_TREE;
@@ -580,16 +623,19 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
   bool entry_master;
 
   sym = expr->symtree->n.sym;
-  if (se->ss != NULL)
+  ss = se->ss;
+  if (ss != NULL)
     {
+      gfc_ss_info *ss_info = ss->info;
+
       /* Check that something hasn't gone horribly wrong.  */
-      gcc_assert (se->ss != gfc_ss_terminator);
-      gcc_assert (se->ss->expr == expr);
+      gcc_assert (ss != gfc_ss_terminator);
+      gcc_assert (ss_info->expr == expr);
 
       /* A scalarized term.  We already know the descriptor.  */
-      se->expr = se->ss->data.info.descriptor;
-      se->string_length = se->ss->string_length;
-      for (ref = se->ss->data.info.ref; ref; ref = ref->next)
+      se->expr = ss_info->data.array.descriptor;
+      se->string_length = ss_info->string_length;
+      for (ref = ss_info->data.array.ref; ref; ref = ref->next)
        if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
          break;
     }
@@ -677,8 +723,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
        }
       else if (!sym->attr.value)
        {
-          /* Dereference non-character scalar dummy arguments.  */
-         if (sym->attr.dummy && !sym->attr.dimension)
+         /* Dereference non-character scalar dummy arguments.  */
+         if (sym->attr.dummy && !sym->attr.dimension
+             && !(sym->attr.codimension && sym->attr.allocatable))
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);
 
@@ -697,7 +744,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
              && (sym->attr.dummy
                  || sym->attr.function
                  || sym->attr.result
-                 || !sym->attr.dimension))
+                 || (!sym->attr.dimension
+                     && (!sym->attr.codimension || !sym->attr.allocatable))))
            se->expr = build_fold_indirect_ref_loc (input_location,
                                                se->expr);
        }
@@ -1080,22 +1128,22 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
              switch (kind)
                {
                case 0:
-                 fndecl = built_in_decls[BUILT_IN_POWIF];
+                 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
                  break;
                
                case 1:
-                 fndecl = built_in_decls[BUILT_IN_POWI];
+                 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
                  break;
 
                case 2:
-                 fndecl = built_in_decls[BUILT_IN_POWIL];
+                 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
                  break;
 
                case 3:
                  /* Use the __builtin_powil() only if real(kind=16) is 
                     actually the C long double type.  */
                  if (!gfc_real16_is_float128)
-                   fndecl = built_in_decls[BUILT_IN_POWIL];
+                   fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
                  break;
 
                default:
@@ -1722,14 +1770,14 @@ gfc_free_interface_mapping (gfc_interface_mapping * mapping)
       sym->new_sym->n.sym->formal = NULL;
       gfc_free_symbol (sym->new_sym->n.sym);
       gfc_free_expr (sym->expr);
-      gfc_free (sym->new_sym);
-      gfc_free (sym);
+      free (sym->new_sym);
+      free (sym);
     }
   for (cl = mapping->charlens; cl; cl = nextcl)
     {
       nextcl = cl->next;
       gfc_free_expr (cl->length);
-      gfc_free (cl);
+      free (cl);
     }
 }
 
@@ -2233,6 +2281,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
          expr->symtree = sym->new_sym;
        else if (sym->expr)
          gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+       /* Replace base type for polymorphic arguments.  */
+       if (expr->ref && expr->ref->type == REF_COMPONENT
+           && sym->expr && sym->expr->ts.type == BT_CLASS)
+         expr->ref->u.c.sym = sym->expr->ts.u.derived;
       }
 
       /* ...and to subexpressions in expr->value.  */
@@ -2311,7 +2363,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   gfc_ss *rss;
   gfc_loopinfo loop;
   gfc_loopinfo loop2;
-  gfc_ss_info *info;
+  gfc_array_info *info;
   tree offset;
   tree tmp_index;
   tree tmp;
@@ -2347,18 +2399,12 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
                || GFC_DESCRIPTOR_TYPE_P (base_type))
     base_type = gfc_get_element_type (base_type);
 
-  loop.temp_ss = gfc_get_ss ();;
-  loop.temp_ss->type = GFC_SS_TEMP;
-  loop.temp_ss->data.temp.type = base_type;
-
-  if (expr->ts.type == BT_CHARACTER)
-    loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
-  else
-    loop.temp_ss->string_length = NULL;
+  loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+                                             ? expr->ts.u.cl->backend_decl
+                                             : NULL),
+                                 loop.dimen);
 
-  parmse->string_length = loop.temp_ss->string_length;
-  loop.temp_ss->data.temp.dimen = loop.dimen;
-  loop.temp_ss->next = gfc_ss_terminator;
+  parmse->string_length = loop.temp_ss->info->string_length;
 
   /* Associate the SS with the loop.  */
   gfc_add_ss_to_loop (&loop, loop.temp_ss);
@@ -2367,7 +2413,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   gfc_conv_loop_setup (&loop, &expr->where);
 
   /* Pass the temporary descriptor back to the caller.  */
-  info = &loop.temp_ss->data.info;
+  info = &loop.temp_ss->info->data.array;
   parmse->expr = info->descriptor;
 
   /* Setup the gfc_se structures.  */
@@ -2446,8 +2492,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
      dimensions, so this is very simple.  The offset is only computed
      outside the innermost loop, so the overall transfer could be
      optimized further.  */
-  info = &rse.ss->data.info;
-  dimen = info->dimen;
+  info = &rse.ss->info->data.array;
+  dimen = rse.ss->dimen;
 
   tmp_index = gfc_index_zero_node;
   for (n = dimen - 1; n > 0; n--)
@@ -2794,6 +2840,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
   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.
@@ -2811,7 +2858,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   tree fntype;
   gfc_se parmse;
   gfc_ss *argss;
-  gfc_ss_info *info;
+  gfc_array_info *info;
   int byref;
   int parm_kind;
   tree type;
@@ -2850,8 +2897,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     {
       if (!sym->attr.elemental)
        {
-         gcc_assert (se->ss->type == GFC_SS_FUNCTION);
-         if (se->ss->useflags)
+         gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
+         if (se->ss->info->useflags)
            {
              gcc_assert ((!comp && gfc_return_by_reference (sym)
                           && sym->result->attr.dimension)
@@ -2863,7 +2910,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              return 0;
            }
        }
-      info = &se->ss->data.info;
+      info = &se->ss->info->data.array;
     }
   else
     info = NULL;
@@ -2936,7 +2983,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          gfc_init_se (&parmse, se);
          gfc_conv_derived_to_class (&parmse, e, fsym->ts);
        }
-      else if (se->ss && se->ss->useflags)
+      else if (se->ss && se->ss->info->useflags)
        {
          /* An elemental function inside a scalarized loop.  */
          gfc_init_se (&parmse, se);
@@ -3042,8 +3089,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                           && fsym->attr.flavor != FL_PROCEDURE)
                          || (fsym->attr.proc_pointer
                              && !(e->expr_type == EXPR_VARIABLE
-                             && e->symtree->n.sym->attr.dummy))
-                         || (e->expr_type == EXPR_VARIABLE
+                                  && e->symtree->n.sym->attr.dummy))
+                         || (fsym->attr.proc_pointer
+                             && e->expr_type == EXPR_VARIABLE
                              && gfc_is_proc_ptr_comp (e, NULL))
                          || fsym->attr.allocatable))
                    {
@@ -3078,6 +3126,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                 argument and another one.  */
              if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
                {
+                 gfc_expr *iarg;
                  sym_intent intent;
 
                  if (fsym != NULL)
@@ -3088,6 +3137,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                  if (gfc_check_fncall_dependency (e, intent, sym, args,
                                                   NOT_ELEMENTAL))
                    parmse.force_tmp = 1;
+
+                 iarg = e->value.function.actual->expr;
+
+                 /* Temporary needed if aliasing due to host association.  */
+                 if (sym->attr.contained
+                       && !sym->attr.pure
+                       && !sym->attr.implicit_pure
+                       && !sym->attr.use_assoc
+                       && iarg->expr_type == EXPR_VARIABLE
+                       && sym->ns == iarg->symtree->n.sym->ns)
+                   parmse.force_tmp = 1;
+
+                 /* Ditto within module.  */
+                 if (sym->attr.use_assoc
+                       && !sym->attr.pure
+                       && !sym->attr.implicit_pure
+                       && iarg->expr_type == EXPR_VARIABLE
+                       && sym->module == iarg->symtree->n.sym->module)
+                   parmse.force_tmp = 1;
                }
 
              if (e->expr_type == EXPR_VARIABLE
@@ -3230,6 +3298,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          else
            goto end_pointer_check;
 
+         /*  In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
+             allocatable to an optional dummy, cf. 12.5.2.12.  */
+         if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
+             && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+           goto end_pointer_check;
+
           if (attr.optional)
            {
               /* If the actual argument is an optional pointer/allocatable and
@@ -3287,25 +3361,123 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              else
                goto end_pointer_check;
 
+             tmp = parmse.expr;
+
+             /* If the argument is passed by value, we need to strip the
+                INDIRECT_REF.  */
+             if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+               tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 
              cond = fold_build2_loc (input_location, EQ_EXPR,
-                                     boolean_type_node, parmse.expr,
-                                     fold_convert (TREE_TYPE (parmse.expr),
+                                     boolean_type_node, tmp,
+                                     fold_convert (TREE_TYPE (tmp),
                                                    null_pointer_node));
            }
  
          gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
                                   msg);
-         gfc_free (msg);
+         free (msg);
         }
       end_pointer_check:
 
+      /* Deferred length dummies pass the character length by reference
+        so that the value can be returned.  */
+      if (parmse.string_length && fsym && fsym->ts.deferred)
+       {
+         tmp = parmse.string_length;
+         if (TREE_CODE (tmp) != VAR_DECL)
+           tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+         parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+       }
 
       /* 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)
        VEC_safe_push (tree, gc, stringargs, parmse.string_length);
 
+      /* For descriptorless coarrays and assumed-shape coarray dummies, we
+        pass the token and the offset as additional arguments.  */
+      if (fsym && fsym->attr.codimension
+         && gfc_option.coarray == GFC_FCOARRAY_LIB
+         && !fsym->attr.allocatable
+         && e == NULL)
+       {
+         /* Token and offset. */
+         VEC_safe_push (tree, gc, stringargs, null_pointer_node);
+         VEC_safe_push (tree, gc, stringargs,
+                        build_int_cst (gfc_array_index_type, 0));
+         gcc_assert (fsym->attr.optional);
+       }
+      else if (fsym && fsym->attr.codimension
+              && !fsym->attr.allocatable
+              && gfc_option.coarray == GFC_FCOARRAY_LIB)
+       {
+         tree caf_decl, caf_type;
+         tree offset, tmp2;
+
+         caf_decl = get_tree_for_caf_expr (e);
+         caf_type = TREE_TYPE (caf_decl);
+
+         if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+             && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+           tmp = gfc_conv_descriptor_token (caf_decl);
+         else if (DECL_LANG_SPECIFIC (caf_decl)
+                  && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+           tmp = GFC_DECL_TOKEN (caf_decl);
+         else
+           {
+             gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+                         && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+             tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+           }
+         
+         VEC_safe_push (tree, gc, stringargs, tmp);
+
+         if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+             && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+           offset = build_int_cst (gfc_array_index_type, 0);
+         else if (DECL_LANG_SPECIFIC (caf_decl)
+                  && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+           offset = GFC_DECL_CAF_OFFSET (caf_decl);
+         else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+           offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+         else
+           offset = build_int_cst (gfc_array_index_type, 0);
+
+         if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+           tmp = gfc_conv_descriptor_data_get (caf_decl);
+         else
+           {
+             gcc_assert (POINTER_TYPE_P (caf_type));
+             tmp = caf_decl;
+           }
+
+          if (fsym->as->type == AS_ASSUMED_SHAPE)
+           {
+             gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+             gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+                                                  (TREE_TYPE (parmse.expr))));
+             tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+             tmp2 = gfc_conv_descriptor_data_get (tmp2);
+           }
+         else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+           tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+         else
+           {
+             gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+             tmp2 = parmse.expr;
+           }
+
+         tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                 gfc_array_index_type,
+                                 fold_convert (gfc_array_index_type, tmp2),
+                                 fold_convert (gfc_array_index_type, tmp));
+         offset = fold_build2_loc (input_location, PLUS_EXPR,
+                                   gfc_array_index_type, offset, tmp);
+
+         VEC_safe_push (tree, gc, stringargs, offset);
+       }
+
       VEC_safe_push (tree, gc, arglist, parmse.expr);
     }
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
@@ -3327,7 +3499,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
             we take the character length of the first argument for the result.
             For dummies, we have to look through the formal argument list for
             this function and use the character length found there.*/
-         if (!sym->attr.dummy)
+         if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+           cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
+         else if (!sym->attr.dummy)
            cl.backend_decl = VEC_index (tree, stringargs, 0);
          else
            {
@@ -3382,7 +3556,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
          /* If the lhs of an assignment x = f(..) is allocatable and
             f2003 is allowed, we must do the automatic reallocation.
-            TODO - deal with instrinsics, without using a temporary.  */
+            TODO - deal with intrinsics, without using a temporary.  */
          if (gfc_option.flag_realloc_lhs
                && se->ss && se->ss->loop_chain
                && se->ss->loop_chain->is_alloc_lhs
@@ -3412,7 +3586,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
          /* Set the type of the array.  */
          tmp = gfc_typenode_for_spec (&comp->ts);
-         info->dimen = se->loop->dimen;
+         gcc_assert (se->ss->dimen == se->loop->dimen);
 
          /* Evaluate the bounds of the result, if known.  */
          gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
@@ -3432,9 +3606,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
             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);
+         gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+                                      tmp, NULL_TREE, false,
+                                      !comp->attr.pointer, callee_alloc,
+                                      &se->ss->info->expr->where);
 
          /* Pass the temporary as the first argument.  */
          result = info->descriptor;
@@ -3447,7 +3622,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
          /* Set the type of the array.  */
          tmp = gfc_typenode_for_spec (&ts);
-         info->dimen = se->loop->dimen;
+         gcc_assert (se->ss->dimen == se->loop->dimen);
 
          /* Evaluate the bounds of the result, if known.  */
          gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
@@ -3467,9 +3642,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
             returns a pointer, the temporary will be a shallow copy and
             mustn't be deallocated.  */
          callee_alloc = sym->attr.allocatable || sym->attr.pointer;
-         gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
-                                      NULL_TREE, false, !sym->attr.pointer,
-                                      callee_alloc, &se->ss->expr->where);
+         gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+                                      tmp, NULL_TREE, false,
+                                      !sym->attr.pointer, callee_alloc,
+                                      &se->ss->info->expr->where);
 
          /* Pass the temporary as the first argument.  */
          result = info->descriptor;
@@ -3512,6 +3688,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          VEC_safe_push (tree, gc, retargs, var);
        }
 
+      if (ts.type == BT_CHARACTER && ts.deferred
+           && (sym->attr.allocatable || sym->attr.pointer))
+       {
+         tmp = len;
+         if (TREE_CODE (tmp) != VAR_DECL)
+           tmp = gfc_evaluate_now (len, &se->pre);
+         len = gfc_build_addr_expr (NULL_TREE, tmp);
+       }
+
       /* Add the string length to the argument list.  */
       if (ts.type == BT_CHARACTER)
        VEC_safe_push (tree, gc, retargs, len);
@@ -3541,7 +3726,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   /* If there are alternate return labels, function type should be
      integer.  Can't modify the type in place though, since it can be shared
      with other functions.  For dummy arguments, the typing is done to
-     to this result, even if it has to be repeated for each call.  */
+     this result, even if it has to be repeated for each call.  */
   if (has_alternate_specifier
       && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
     {
@@ -3564,10 +3749,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
         x = f()
      where f is pointer valued, we have to dereference the result.  */
   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);
+      && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+         || (comp && (comp->attr.pointer || comp->attr.allocatable))))
+    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
@@ -3594,7 +3778,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       if (!se->direct_byref)
        {
-         if (sym->attr.dimension || (comp && comp->attr.dimension))
+         if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
            {
              if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
                {
@@ -3620,7 +3804,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              else
                se->expr = var;
 
-             se->string_length = len;
+             if (!ts.deferred)
+               se->string_length = len;
+             else if (sym->attr.allocatable || sym->attr.pointer)
+               se->string_length = cl.backend_decl;
            }
          else
            {
@@ -3680,7 +3867,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_loc (input_location,
-                           built_in_decls[BUILT_IN_MEMSET], 3, start,
+                           builtin_decl_explicit (BUILT_IN_MEMSET),
+                           3, start,
                            build_int_cst (gfc_get_int_type (gfc_c_int_kind),
                                           lang_hooks.to_target_charset (' ')),
                            size);
@@ -3721,8 +3909,8 @@ fill_with_spaces (tree start, tree type, tree size)
                  fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
                                   TYPE_SIZE_UNIT (type)));
   gfc_add_modify (&loop, el,
-                 fold_build2_loc (input_location, POINTER_PLUS_EXPR,
-                                  TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
+                 fold_build_pointer_plus_loc (input_location,
+                                              el, TYPE_SIZE_UNIT (type)));
 
   /* Making the loop... actually loop!  */
   tmp = gfc_finish_block (&loop);
@@ -3840,16 +4028,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
   cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
                           dlen);
   tmp2 = build_call_expr_loc (input_location,
-                         built_in_decls[BUILT_IN_MEMMOVE],
-                         3, dest, src, dlen);
+                             builtin_decl_explicit (BUILT_IN_MEMMOVE),
+                             3, dest, src, dlen);
 
   /* Else copy and pad with spaces.  */
   tmp3 = build_call_expr_loc (input_location,
-                         built_in_decls[BUILT_IN_MEMMOVE],
-                         3, dest, src, slen);
+                             builtin_decl_explicit (BUILT_IN_MEMMOVE),
+                             3, dest, src, slen);
 
-  tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
-                         dest, fold_convert (sizetype, slen));
+  tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
   tmp4 = fill_with_spaces (tmp4, chartype,
                           fold_build2_loc (input_location, MINUS_EXPR,
                                            TREE_TYPE(dlen), dlen, slen));
@@ -3896,8 +4083,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
   n = 0;
   for (fargs = sym->formal; fargs; fargs = fargs->next)
     n++;
-  saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
-  temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
+  saved_vars = XCNEWVEC (gfc_saved_var, n);
+  temp_vars = XCNEWVEC (tree, n);
 
   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
     {
@@ -3981,7 +4168,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
   /* Restore the original variables.  */
   for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
     gfc_restore_sym (fargs->sym, &saved_vars[n]);
-  gfc_free (saved_vars);
+  free (saved_vars);
 }
 
 
@@ -4056,8 +4243,11 @@ is_zero_initializer_p (gfc_expr * expr)
 static void
 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
 {
-  gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
-  gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+  gfc_ss *ss;
+
+  ss = se->ss;
+  gcc_assert (ss != NULL && ss != gfc_ss_terminator);
+  gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
 
   gfc_conv_tmp_array_ref (se);
 }
@@ -4161,6 +4351,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   gfc_se lse;
   gfc_ss *rss;
   gfc_ss *lss;
+  gfc_array_info *lss_array;
   stmtblock_t body;
   stmtblock_t block;
   gfc_loopinfo loop;
@@ -4178,34 +4369,26 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   /* Walk the rhs.  */
   rss = gfc_walk_expr (expr);
   if (rss == gfc_ss_terminator)
-    {
-      /* The rhs is scalar.  Add a ss for the expression.  */
-      rss = gfc_get_ss ();
-      rss->next = gfc_ss_terminator;
-      rss->type = GFC_SS_SCALAR;
-      rss->expr = expr;
-    }
+    /* The rhs is scalar.  Add a ss for the expression.  */
+    rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
 
   /* Create a SS for the destination.  */
-  lss = gfc_get_ss ();
-  lss->type = GFC_SS_COMPONENT;
-  lss->expr = NULL;
-  lss->shape = gfc_get_shape (cm->as->rank);
-  lss->next = gfc_ss_terminator;
-  lss->data.info.dimen = cm->as->rank;
-  lss->data.info.descriptor = dest;
-  lss->data.info.data = gfc_conv_array_data (dest);
-  lss->data.info.offset = gfc_conv_array_offset (dest);
+  lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+                         GFC_SS_COMPONENT);
+  lss_array = &lss->info->data.array;
+  lss_array->shape = gfc_get_shape (cm->as->rank);
+  lss_array->descriptor = dest;
+  lss_array->data = gfc_conv_array_data (dest);
+  lss_array->offset = gfc_conv_array_offset (dest);
   for (n = 0; n < cm->as->rank; n++)
     {
-      lss->data.info.dim[n] = n;
-      lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
-      lss->data.info.stride[n] = gfc_index_one_node;
+      lss_array->start[n] = gfc_conv_array_lbound (dest, n);
+      lss_array->stride[n] = gfc_index_one_node;
 
-      mpz_init (lss->shape[n]);
-      mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
+      mpz_init (lss_array->shape[n]);
+      mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
               cm->as->lower[n]->value.integer);
-      mpz_add_ui (lss->shape[n], lss->shape[n], 1);
+      mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
     }
   
   /* Associate the SS with the loop.  */
@@ -4248,10 +4431,8 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   gfc_add_block_to_block (&block, &loop.pre);
   gfc_add_block_to_block (&block, &loop.post);
 
-  for (n = 0; n < cm->as->rank; n++)
-    mpz_clear (lss->shape[n]);
-  gfc_free (lss->shape);
-
+  gcc_assert (lss_array->shape != NULL);
+  gfc_free_shape (&lss_array->shape, cm->as->rank);
   gfc_cleanup_loop (&loop);
 
   return gfc_finish_block (&block);
@@ -4452,7 +4633,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
                                        gfc_class_null_initializer (&cm->ts));
       gfc_add_expr_to_block (&block, tmp);
     }
-  else if (cm->attr.dimension)
+  else if (cm->attr.dimension && !cm->attr.proc_pointer)
     {
       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
        gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
@@ -4514,6 +4695,24 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
 
   gfc_start_block (&block);
   cm = expr->ts.u.derived->components;
+
+  if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+      && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+          || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+    {
+      gfc_se se, lse;
+
+      gcc_assert (cm->backend_decl == NULL);
+      gfc_init_se (&se, NULL);
+      gfc_init_se (&lse, NULL);
+      gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+      lse.expr = dest;
+      gfc_add_modify (&block, lse.expr,
+                     fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+      return gfc_finish_block (&block);
+    } 
+
   for (c = gfc_constructor_first (expr->value.constructor);
        c; c = gfc_constructor_next (c), cm = cm->next)
     {
@@ -4521,20 +4720,6 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
       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_loc (input_location, COMPONENT_REF,
-                                TREE_TYPE (field),
-                                dest, field, NULL_TREE);
-         tmp = fold_build2_loc (input_location, 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_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
                             dest, field, NULL_TREE);
@@ -4579,7 +4764,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
         components.  Although the latter have a default initializer
         of EXPR_NULL,... by default, the static nullify is not needed
         since this is done every time we come into scope.  */
-      if (!c->expr || cm->attr.allocatable)
+      if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
         continue;
 
       if (strcmp (cm->name, "_size") == 0)
@@ -4643,15 +4828,22 @@ gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
 void
 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
 {
-  if (se->ss && se->ss->expr == expr
-      && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
+  gfc_ss *ss;
+
+  ss = se->ss;
+  if (ss && ss->info->expr == expr
+      && (ss->info->type == GFC_SS_SCALAR
+         || ss->info->type == GFC_SS_REFERENCE))
     {
+      gfc_ss_info *ss_info;
+
+      ss_info = ss->info;
       /* Substitute a scalar expression evaluated outside the scalarization
          loop.  */
-      se->expr = se->ss->data.scalar.expr;
-      if (se->ss->type == GFC_SS_REFERENCE)
+      se->expr = ss_info->data.scalar.value;
+      if (ss_info->type == GFC_SS_REFERENCE)
        se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
-      se->string_length = se->ss->string_length;
+      se->string_length = ss_info->string_length;
       gfc_advance_se_ss_chain (se);
       return;
     }
@@ -4664,8 +4856,10 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
   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)
+      if (expr->expr_type == EXPR_VARIABLE
+         && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+             || expr->symtree->n.sym->intmod_sym_id
+                == ISOCBINDING_NULL_FUNPTR))
         {
          /* Set expr_type to EXPR_NULL, which will result in
             null_pointer_node being used below.  */
@@ -4766,10 +4960,12 @@ gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
 void
 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 {
+  gfc_ss *ss;
   tree var;
 
-  if (se->ss && se->ss->expr == expr
-      && se->ss->type == GFC_SS_REFERENCE)
+  ss = se->ss;
+  if (ss && ss->info->expr == expr
+      && ss->info->type == GFC_SS_REFERENCE)
     {
       /* Returns a reference to the scalar evaluated outside the loop
         for this case.  */
@@ -4891,8 +5087,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       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.  */
+        really added if -fbounds-check is enabled.  Exclude deferred
+        character length lefthand sides.  */
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+         && !(expr1->ts.deferred
+                       && (TREE_CODE (lse.string_length) == VAR_DECL))
          && !expr1->symtree->n.sym->attr.proc_pointer
          && !gfc_is_proc_ptr_comp (expr1, NULL))
        {
@@ -4903,6 +5102,17 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
                                       &block);
        }
 
+      /* The assignment to an deferred character length sets the string
+        length to that of the rhs.  */
+      if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+       {
+         if (expr2->expr_type != EXPR_NULL)
+           gfc_add_modify (&block, lse.string_length, rse.string_length);
+         else
+           gfc_add_modify (&block, lse.string_length,
+                           build_int_cst (gfc_charlen_type_node, 0));
+       }
+
       gfc_add_modify (&block, lse.expr,
                           fold_convert (TREE_TYPE (lse.expr), rse.expr));
 
@@ -5178,8 +5388,6 @@ gfc_conv_string_parameter (gfc_se * se)
     }
 
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
-  gcc_assert (se->string_length
-         && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
 }
 
 
@@ -5317,9 +5525,13 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
   if (gfc_ref_needs_temporary_p (expr1->ref))
     return true;
 
-  /* Functions returning pointers need temporaries.  */
-  if (expr2->symtree->n.sym->attr.pointer 
-      || expr2->symtree->n.sym->attr.allocatable)
+  /* Functions returning pointers or allocatables need temporaries.  */
+  c = expr2->value.function.esym
+      ? (expr2->value.function.esym->attr.pointer 
+        || expr2->value.function.esym->attr.allocatable)
+      : (expr2->symtree->n.sym->attr.pointer
+        || expr2->symtree->n.sym->attr.allocatable);
+  if (c)
     return true;
 
   /* Character array functions need temporaries unless the
@@ -5361,27 +5573,46 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
     return true;
 
   /* If we have reached here with an intrinsic function, we do not
-     need a temporary.  */
+     need a temporary except in the particular case that reallocation
+     on assignment is active and the lhs is allocatable and a target.  */
   if (expr2->value.function.isym)
-    return false;
+    return (gfc_option.flag_realloc_lhs
+             && sym->attr.allocatable
+             && sym->attr.target);
 
   /* If the LHS is a dummy, we need a temporary if it is not
      INTENT(OUT).  */
   if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
     return true;
 
+  /* If the lhs has been host_associated, is in common, a pointer or is
+     a target and the function is not using a RESULT variable, aliasing
+     can occur and a temporary is needed.  */
+  if ((sym->attr.host_assoc
+          || sym->attr.in_common
+          || sym->attr.pointer
+          || sym->attr.cray_pointee
+          || sym->attr.target)
+       && expr2->symtree != NULL
+       && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+    return true;
+
   /* A PURE function can unconditionally be called without a temporary.  */
   if (expr2->value.function.esym != NULL
       && expr2->value.function.esym->attr.pure)
     return false;
 
-  /* TODO a function that could correctly be declared PURE but is not
-     could do with returning false as well.  */
+  /* Implicit_pure functions are those which could legally be declared
+     to be PURE.  */
+  if (expr2->value.function.esym != NULL
+      && expr2->value.function.esym->attr.implicit_pure)
+    return false;
 
   if (!sym->attr.use_assoc
        && !sym->attr.in_common
        && !sym->attr.pointer
        && !sym->attr.target
+       && !sym->attr.cray_pointee
        && expr2->value.function.esym)
     {
       /* A temporary is not needed if the function is not contained and
@@ -5411,41 +5642,56 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
    reallocatable assignments from extrinsic function calls.  */
 
 static void
-realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
+                              gfc_loopinfo *loop)
 {
-  gfc_loopinfo loop;
   /* Signal that the function call should not be made by
      gfc_conv_loop_setup. */
   se->ss->is_alloc_lhs = 1;
-  gfc_init_loopinfo (&loop);
-  gfc_add_ss_to_loop (&loop, *ss);
-  gfc_add_ss_to_loop (&loop, se->ss);
-  gfc_conv_ss_startstride (&loop);
-  gfc_conv_loop_setup (&loop, where);
-  gfc_copy_loopinfo_to_se (se, &loop);
-  gfc_add_block_to_block (&se->pre, &loop.pre);
-  gfc_add_block_to_block (&se->pre, &loop.post);
+  gfc_init_loopinfo (loop);
+  gfc_add_ss_to_loop (loop, *ss);
+  gfc_add_ss_to_loop (loop, se->ss);
+  gfc_conv_ss_startstride (loop);
+  gfc_conv_loop_setup (loop, where);
+  gfc_copy_loopinfo_to_se (se, loop);
+  gfc_add_block_to_block (&se->pre, &loop->pre);
+  gfc_add_block_to_block (&se->pre, &loop->post);
   se->ss->is_alloc_lhs = 0;
 }
 
 
+/* For Assignment to a reallocatable lhs from intrinsic functions,
+   replace the se.expr (ie. the result) with a temporary descriptor.
+   Null the data field so that the library allocates space for the
+   result. Free the data of the original descriptor after the function,
+   in case it appears in an argument expression and transfer the
+   result to the original descriptor.  */
+
 static void
-realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se, int rank)
 {
   tree desc;
+  tree res_desc;
   tree tmp;
   tree offset;
   int n;
 
-  /* Use the allocation done by the library.  */
+  /* Use the allocation done by the library.  Substitute the lhs
+     descriptor with a copy, whose data field is nulled.*/
   desc = build_fold_indirect_ref_loc (input_location, se->expr);
-  tmp = gfc_conv_descriptor_data_get (desc);
-  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
-  gfc_add_expr_to_block (&se->pre, tmp);
-  gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
   /* Unallocated, the descriptor does not have a dtype.  */
   tmp = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  res_desc = gfc_evaluate_now (desc, &se->pre);
+  gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+  se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+  /* Free the lhs after the function call and copy the result to
+     the lhs descriptor.  */
+  tmp = gfc_conv_descriptor_data_get (desc);
+  tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+  gfc_add_expr_to_block (&se->post, tmp);
+  gfc_add_modify (&se->post, desc, res_desc);
 
   offset = gfc_index_zero_node;
   tmp = gfc_index_one_node;
@@ -5492,6 +5738,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_se se;
   gfc_ss *ss;
   gfc_component *comp = NULL;
+  gfc_loopinfo loop;
 
   if (arrayfunc_assign_needs_temporary (expr1, expr2))
     return NULL;
@@ -5542,11 +5789,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
     {
       if (!expr2->value.function.isym)
        {
-         realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+         realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
          ss->is_alloc_lhs = 1;
        }
       else
-       realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+       fcncall_realloc_result (&se, expr1->rank);
     }
 
   gfc_conv_function_expr (&se, expr2);
@@ -5596,8 +5843,8 @@ gfc_trans_zero_assign (gfc_expr * expr)
 
   /* Construct call to __builtin_memset.  */
   tmp = build_call_expr_loc (input_location,
-                        built_in_decls[BUILT_IN_MEMSET],
-                        3, dest, integer_zero_node, len);
+                            builtin_decl_explicit (BUILT_IN_MEMSET),
+                            3, dest, integer_zero_node, len);
   return fold_convert (void_type_node, tmp);
 }
 
@@ -5625,7 +5872,8 @@ gfc_build_memcpy_call (tree dst, tree src, tree len)
 
   /* Construct call to __builtin_memcpy.  */
   tmp = build_call_expr_loc (input_location,
-                        built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+                            builtin_decl_explicit (BUILT_IN_MEMCPY),
+                            3, dst, src, len);
   return fold_convert (void_type_node, tmp);
 }
 
@@ -5748,6 +5996,136 @@ expr_is_variable (gfc_expr *expr)
 }
 
 
+/* Is the lhs OK for automatic reallocation?  */
+
+static bool
+is_scalar_reallocatable_lhs (gfc_expr *expr)
+{
+  gfc_ref * ref;
+
+  /* An allocatable variable with no reference.  */
+  if (expr->symtree->n.sym->attr.allocatable
+       && !expr->ref)
+    return true;
+
+  /* All that can be left are allocatable components.  */
+  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+       && expr->symtree->n.sym->ts.type != BT_CLASS)
+       || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+    return false;
+
+  /* Find an allocatable component ref last.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT
+         && !ref->next
+         && ref->u.c.component->attr.allocatable)
+      return true;
+
+  return false;
+}
+
+
+/* Allocate or reallocate scalar lhs, as necessary.  */
+
+static void
+alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
+                                        tree string_length,
+                                        gfc_expr *expr1,
+                                        gfc_expr *expr2)
+
+{
+  tree cond;
+  tree tmp;
+  tree size;
+  tree size_in_bytes;
+  tree jump_label1;
+  tree jump_label2;
+  gfc_se lse;
+
+  if (!expr1 || expr1->rank)
+    return;
+
+  if (!expr2 || expr2->rank)
+    return;
+
+  /* Since this is a scalar lhs, we can afford to do this.  That is,
+     there is no risk of side effects being repeated.  */
+  gfc_init_se (&lse, NULL);
+  lse.want_pointer = 1;
+  gfc_conv_expr (&lse, expr1);
+  
+  jump_label1 = gfc_build_label_decl (NULL_TREE);
+  jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+  /* Do the allocation if the lhs is NULL. Otherwise go to label 1.  */
+  tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                         lse.expr, tmp);
+  tmp = build3_v (COND_EXPR, cond,
+                 build1_v (GOTO_EXPR, jump_label1),
+                 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Use the rhs string length and the lhs element size.  */
+      size = string_length;
+      tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+      tmp = TYPE_SIZE_UNIT (tmp);
+      size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+                                      TREE_TYPE (tmp), tmp,
+                                      fold_convert (TREE_TYPE (tmp), size));
+    }
+  else
+    {
+      /* Otherwise use the length in bytes of the rhs.  */
+      size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+      size_in_bytes = size;
+    }
+
+  tmp = build_call_expr_loc (input_location,
+                            builtin_decl_explicit (BUILT_IN_MALLOC),
+                            1, size_in_bytes);
+  tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+  gfc_add_modify (block, lse.expr, tmp);
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      /* Deferred characters need checking for lhs and rhs string
+        length.  Other deferred parameter variables will have to
+        come here too.  */
+      tmp = build1_v (GOTO_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+    }
+  tmp = build1_v (LABEL_EXPR, jump_label1);
+  gfc_add_expr_to_block (block, tmp);
+
+  /* For a deferred length character, reallocate if lengths of lhs and
+     rhs are different.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                             expr1->ts.u.cl->backend_decl, size);
+      /* Jump past the realloc if the lengths are the same.  */
+      tmp = build3_v (COND_EXPR, cond,
+                     build1_v (GOTO_EXPR, jump_label2),
+                     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (block, tmp);
+      tmp = build_call_expr_loc (input_location,
+                                builtin_decl_explicit (BUILT_IN_REALLOC),
+                                2, fold_convert (pvoid_type_node, lse.expr),
+                                size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+      gfc_add_modify (block, lse.expr, tmp);
+      tmp = build1_v (LABEL_EXPR, jump_label2);
+      gfc_add_expr_to_block (block, tmp);
+
+      /* Update the lhs character length.  */
+      size = string_length;
+      gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+    }
+}
+
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -5768,6 +6146,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   stmtblock_t body;
   bool l_is_temp;
   bool scalar_to_array;
+  bool def_clen_func;
   tree string_length;
   int n;
 
@@ -5786,16 +6165,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   rss = NULL;
   if (lss != gfc_ss_terminator)
     {
-      /* Allow the scalarizer to workshare array assignments.  */
-      if (ompws_flags & OMPWS_WORKSHARE_FLAG)
-       ompws_flags |= OMPWS_SCALARIZER_WS;
-
       /* The assignment needs scalarization.  */
       lss_section = lss;
 
       /* Find a non-scalar SS from the lhs.  */
       while (lss_section != gfc_ss_terminator
-            && lss_section->type != GFC_SS_SECTION)
+            && lss_section->info->type != GFC_SS_SECTION)
        lss_section = lss_section->next;
 
       gcc_assert (lss_section != gfc_ss_terminator);
@@ -5806,13 +6181,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Walk the rhs.  */
       rss = gfc_walk_expr (expr2);
       if (rss == gfc_ss_terminator)
-       {
-         /* The rhs is scalar.  Add a ss for the expression.  */
-         rss = gfc_get_ss ();
-         rss->next = gfc_ss_terminator;
-         rss->type = GFC_SS_SCALAR;
-         rss->expr = expr2;
-       }
+       /* The rhs is scalar.  Add a ss for the expression.  */
+       rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
       /* Associate the SS with the loop.  */
       gfc_add_ss_to_loop (&loop, lss);
       gfc_add_ss_to_loop (&loop, rss);
@@ -5820,8 +6191,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Calculate the bounds of the scalarization.  */
       gfc_conv_ss_startstride (&loop);
       /* Enable loop reversal.  */
-      for (n = 0; n < loop.dimen; n++)
-       loop.reverse[n] = GFC_REVERSE_NOT_SET;
+      for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+       loop.reverse[n] = GFC_ENABLE_REVERSE;
       /* Resolve any data dependencies in the statement.  */
       gfc_conv_resolve_dependencies (&loop, lss, rss);
       /* Setup the scalarizing loops.  */
@@ -5845,6 +6216,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
          gfc_mark_ss_chain_used (loop.temp_ss, 3);
        }
 
+      /* Allow the scalarizer to workshare array assignments.  */
+      if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
+       ompws_flags |= OMPWS_SCALARIZER_WS;
+
       /* Start the scalarized loop body.  */
       gfc_start_scalarized_body (&loop, &body);
     }
@@ -5885,14 +6260,33 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       gfc_add_expr_to_block (&loop.post, tmp);
     }
 
+  /* For a deferred character length function, the function call must
+     happen before the (re)allocation of the lhs, otherwise the character
+     length of the result is not known.  */
+  def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
+                          || (expr2->expr_type == EXPR_COMPCALL)
+                          || (expr2->expr_type == EXPR_PPC))
+                      && expr2->ts.deferred);
+  if (gfc_option.flag_realloc_lhs
+       && expr2->ts.type == BT_CHARACTER
+       && (def_clen_func || expr2->expr_type == EXPR_OP)
+       && expr1->ts.deferred)
+    gfc_add_block_to_block (&block, &rse.pre);
+
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
                                 l_is_temp || init_flag,
-                                expr_is_variable (expr2) || scalar_to_array,
-                                dealloc);
+                                expr_is_variable (expr2) || scalar_to_array
+                                || expr2->expr_type == EXPR_ARRAY, dealloc);
   gfc_add_expr_to_block (&body, tmp);
 
   if (lss == gfc_ss_terminator)
     {
+      /* F2003: Add the code for reallocation on assignment.  */
+      if (gfc_option.flag_realloc_lhs
+           && is_scalar_reallocatable_lhs (expr1))
+       alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+                                                expr1, expr2);
+
       /* Use the scalar assignment as is.  */
       gfc_add_block_to_block (&block, &body);
     }
@@ -5928,12 +6322,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
          gfc_add_expr_to_block (&body, tmp);
        }
 
-      /* Allocate or reallocate lhs of allocatable array.  */
+      /* F2003: Allocate or reallocate lhs of allocatable array.  */
       if (gfc_option.flag_realloc_lhs
            && gfc_is_reallocatable_lhs (expr1)
            && !gfc_expr_attr (expr1).codimension
            && !gfc_is_coindexed (expr1))
        {
+         ompws_flags &= ~OMPWS_SCALARIZER_WS;
          tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
          if (tmp != NULL_TREE)
            gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
@@ -5997,13 +6392,6 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
                      bool dealloc)
 {
   tree tmp;
-  
-  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
-    {
-      gfc_error ("Assignment to deferred-length character variable at %L "
-                "not implemented", &expr1->where);
-      return NULL_TREE;
-    }
 
   /* Special case a single function returning an array.  */
   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
@@ -6079,6 +6467,11 @@ gfc_trans_class_init_assign (gfc_code *code)
 
   rhs = gfc_copy_expr (code->expr1);
   gfc_add_vptr_component (rhs);
+
+  /* Make sure that the component backend_decls have been built, which
+     will not have happened if the derived types concerned have not
+     been referenced.  */
+  gfc_get_derived_type (rhs->ts.u.derived);
   gfc_add_def_init_component (rhs);
 
   sz = gfc_copy_expr (code->expr1);
@@ -6115,24 +6508,23 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
   if (expr2->ts.type != BT_CLASS)
     {
       /* Insert an additional assignment which sets the '_vptr' field.  */
+      gfc_symbol *vtab = NULL;
+      gfc_symtree *st;
+
       lhs = gfc_copy_expr (expr1);
       gfc_add_vptr_component (lhs);
+
       if (expr2->ts.type == BT_DERIVED)
-       {
-         gfc_symbol *vtab;
-         gfc_symtree *st;
-         vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
-         gcc_assert (vtab);
-         rhs = gfc_get_expr ();
-         rhs->expr_type = EXPR_VARIABLE;
-         gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
-         rhs->symtree = st;
-         rhs->ts = vtab->ts;
-       }
+       vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
       else if (expr2->expr_type == EXPR_NULL)
-       rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
-      else
-       gcc_unreachable ();
+       vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+      gcc_assert (vtab);
+
+      rhs = gfc_get_expr ();
+      rhs->expr_type = EXPR_VARIABLE;
+      gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+      rhs->symtree = st;
+      rhs->ts = vtab->ts;
 
       tmp = gfc_trans_pointer_assignment (lhs, rhs);
       gfc_add_expr_to_block (&block, tmp);