]> git.ipfire.org Git - thirdparty/gcc.git/blobdiff - gcc/fortran/trans-array.c
Update copyright years.
[thirdparty/gcc.git] / gcc / fortran / trans-array.c
index 07c4d7e671fd417c988e74d447f2201cbe9daaf0..4bd4db877bd0c33d3a0bfe8db42c7989b43bc3b1 100644 (file)
@@ -1,5 +1,5 @@
 /* Array translation routines
-   Copyright (C) 2002-2019 Free Software Foundation, Inc.
+   Copyright (C) 2002-2021 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -133,25 +133,31 @@ gfc_array_dataptr_type (tree desc)
 #define LBOUND_SUBFIELD 1
 #define UBOUND_SUBFIELD 2
 
+static tree
+gfc_get_descriptor_field (tree desc, unsigned field_idx)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+  tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+  gcc_assert (field != NULL_TREE);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+                         desc, field, NULL_TREE);
+}
+
 /* This provides READ-ONLY access to the data field.  The field itself
    doesn't have the proper type.  */
 
 tree
 gfc_conv_descriptor_data_get (tree desc)
 {
-  tree field, type, t;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = TYPE_FIELDS (type);
-  gcc_assert (DATA_FIELD == 0);
-
-  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
-                      field, NULL_TREE);
-  t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
+  tree type = TREE_TYPE (desc);
+  if (TREE_CODE (type) == REFERENCE_TYPE)
+    gcc_unreachable ();
 
-  return t;
+  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+  return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
 }
 
 /* This provides WRITE access to the data field.
@@ -165,17 +171,8 @@ gfc_conv_descriptor_data_get (tree desc)
 void
 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
 {
-  tree field, type, t;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = TYPE_FIELDS (type);
-  gcc_assert (DATA_FIELD == 0);
-
-  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
-                      field, NULL_TREE);
-  gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
+  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+  gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
 }
 
 
@@ -185,33 +182,16 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
 tree
 gfc_conv_descriptor_data_addr (tree desc)
 {
-  tree field, type, t;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = TYPE_FIELDS (type);
-  gcc_assert (DATA_FIELD == 0);
-
-  t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
-                      field, NULL_TREE);
-  return gfc_build_addr_expr (NULL_TREE, t);
+  tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+  return gfc_build_addr_expr (NULL_TREE, field);
 }
 
 static tree
 gfc_conv_descriptor_offset (tree desc)
 {
-  tree type;
-  tree field;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
-  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                         desc, field, NULL_TREE);
+  tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
+  gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+  return field;
 }
 
 tree
@@ -232,34 +212,17 @@ gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
 tree
 gfc_conv_descriptor_dtype (tree desc)
 {
-  tree field;
-  tree type;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
-  gcc_assert (field != NULL_TREE
-             && TREE_TYPE (field) == get_dtype_type_node ());
-
-  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                         desc, field, NULL_TREE);
+  tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
+  gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
+  return field;
 }
 
 static tree
 gfc_conv_descriptor_span (tree desc)
 {
-  tree type;
-  tree field;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
-  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                         desc, field, NULL_TREE);
+  tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
+  gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+  return field;
 }
 
 tree
@@ -325,22 +288,13 @@ gfc_conv_descriptor_attribute (tree desc)
                          dtype, tmp, NULL_TREE);
 }
 
-
 tree
 gfc_get_descriptor_dimension (tree desc)
 {
-  tree type, field;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
-  field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
-  gcc_assert (field != NULL_TREE
-         && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
-         && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
-
-  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                         desc, field, NULL_TREE);
+  tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
+  gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
+             && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
+  return field;
 }
 
 
@@ -358,38 +312,31 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
 tree
 gfc_conv_descriptor_token (tree desc)
 {
-  tree type;
-  tree field;
-
-  type = TREE_TYPE (desc);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
-  field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
-
+  tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
   /* Should be a restricted pointer - except in the finalization wrapper.  */
-  gcc_assert (field != NULL_TREE
-             && (TREE_TYPE (field) == prvoid_type_node
-                 || TREE_TYPE (field) == pvoid_type_node));
+  gcc_assert (TREE_TYPE (field) == prvoid_type_node
+             || TREE_TYPE (field) == pvoid_type_node);
+  return field;
+}
+
+static tree
+gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
+{
+  tree tmp = gfc_conv_descriptor_dimension (desc, dim);
+  tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
+  gcc_assert (field != NULL_TREE);
 
   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                         desc, field, NULL_TREE);
+                         tmp, field, NULL_TREE);
 }
 
-
 static tree
 gfc_conv_descriptor_stride (tree desc, tree dim)
 {
-  tree tmp;
-  tree field;
-
-  tmp = gfc_conv_descriptor_dimension (desc, dim);
-  field = TYPE_FIELDS (TREE_TYPE (tmp));
-  field = gfc_advance_chain (field, STRIDE_SUBFIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
-  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                        tmp, field, NULL_TREE);
-  return tmp;
+  tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
+  gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+  return field;
 }
 
 tree
@@ -418,17 +365,9 @@ gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
 static tree
 gfc_conv_descriptor_lbound (tree desc, tree dim)
 {
-  tree tmp;
-  tree field;
-
-  tmp = gfc_conv_descriptor_dimension (desc, dim);
-  field = TYPE_FIELDS (TREE_TYPE (tmp));
-  field = gfc_advance_chain (field, LBOUND_SUBFIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
-  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                        tmp, field, NULL_TREE);
-  return tmp;
+  tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
+  gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+  return field;
 }
 
 tree
@@ -448,17 +387,9 @@ gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
 static tree
 gfc_conv_descriptor_ubound (tree desc, tree dim)
 {
-  tree tmp;
-  tree field;
-
-  tmp = gfc_conv_descriptor_dimension (desc, dim);
-  field = TYPE_FIELDS (TREE_TYPE (tmp));
-  field = gfc_advance_chain (field, UBOUND_SUBFIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
-  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-                        tmp, field, NULL_TREE);
-  return tmp;
+  tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
+  gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+  return field;
 }
 
 tree
@@ -537,9 +468,10 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
 
 void
 gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
-                                    tree *dtype_off, tree *dim_off,
-                                    tree *dim_size, tree *stride_suboff,
-                                    tree *lower_suboff, tree *upper_suboff)
+                                    tree *dtype_off, tree *span_off,
+                                    tree *dim_off, tree *dim_size,
+                                    tree *stride_suboff, tree *lower_suboff,
+                                    tree *upper_suboff)
 {
   tree field;
   tree type;
@@ -549,6 +481,8 @@ gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
   *data_off = byte_position (field);
   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
   *dtype_off = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
+  *span_off = byte_position (field);
   field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
   *dim_off = byte_position (field);
   type = TREE_TYPE (TREE_TYPE (field));
@@ -876,7 +810,7 @@ get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
   else
     tmp = sym->backend_decl;
 
-  if (tmp && DECL_LANG_SPECIFIC (tmp))
+  if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
     tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
 
   *desc = tmp;
@@ -1096,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
              gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
              tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
              tmp = gfc_get_element_type (tmp);
-             gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
              packed = gfc_create_var (build_pointer_type (tmp), "data");
 
              tmp = build_call_expr_loc (input_location,
@@ -1205,6 +1138,123 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
 }
 
 
+/* Use the information in the ss to obtain the required information about
+   the type and size of an array temporary, when the lhs in an assignment
+   is a class expression.  */
+
+static tree
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+{
+  gfc_ss *lhs_ss;
+  gfc_ss *rhs_ss;
+  tree tmp;
+  tree tmp2;
+  tree vptr;
+  tree rhs_class_expr = NULL_TREE;
+  tree lhs_class_expr = NULL_TREE;
+  bool unlimited_rhs = false;
+  bool unlimited_lhs = false;
+  bool rhs_function = false;
+  gfc_symbol *vtab;
+
+  /* The second element in the loop chain contains the source for the
+     temporary; ie. the rhs of the assignment.  */
+  rhs_ss = ss->loop->ss->loop_chain;
+
+  if (rhs_ss != gfc_ss_terminator
+      && rhs_ss->info
+      && rhs_ss->info->expr
+      && rhs_ss->info->expr->ts.type == BT_CLASS
+      && rhs_ss->info->data.array.descriptor)
+    {
+      rhs_class_expr
+       = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+      unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
+      if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
+       rhs_function = true;
+    }
+
+  /* For an assignment the lhs is the next element in the loop chain.
+     If we have a class rhs, this had better be a class variable
+     expression!  */
+  lhs_ss = rhs_ss->loop_chain;
+  if (lhs_ss != gfc_ss_terminator
+      && lhs_ss->info
+      && lhs_ss->info->expr
+      && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
+      && lhs_ss->info->expr->ts.type == BT_CLASS)
+    {
+      tmp = lhs_ss->info->data.array.descriptor;
+      unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
+    }
+  else
+    tmp = NULL_TREE;
+
+  /* Get the lhs class expression.  */
+  if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
+    lhs_class_expr = gfc_get_class_from_expr (tmp);
+  else
+    return rhs_class_expr;
+
+  gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
+
+  /* Set the lhs vptr and, if necessary, the _len field.  */
+  if (rhs_class_expr)
+    {
+      /* Both lhs and rhs are class expressions.  */
+      tmp = gfc_class_vptr_get (lhs_class_expr);
+      gfc_add_modify (pre, tmp,
+                     fold_convert (TREE_TYPE (tmp),
+                                   gfc_class_vptr_get (rhs_class_expr)));
+      if (unlimited_lhs)
+       {
+         tmp = gfc_class_len_get (lhs_class_expr);
+         if (unlimited_rhs)
+           tmp2 = gfc_class_len_get (rhs_class_expr);
+         else
+           tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+         gfc_add_modify (pre, tmp, tmp2);
+       }
+
+      if (rhs_function)
+       {
+         tmp = gfc_class_data_get (rhs_class_expr);
+         gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
+       }
+    }
+  else
+   {
+      /* lhs is class and rhs is intrinsic or derived type.  */
+      *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
+      *eltype = gfc_get_element_type (*eltype);
+      vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
+      vptr = vtab->backend_decl;
+      if (vptr == NULL_TREE)
+       vptr = gfc_get_symbol_decl (vtab);
+      vptr = gfc_build_addr_expr (NULL_TREE, vptr);
+      tmp = gfc_class_vptr_get (lhs_class_expr);
+      gfc_add_modify (pre, tmp,
+                     fold_convert (TREE_TYPE (tmp), vptr));
+
+      if (unlimited_lhs)
+       {
+         tmp = gfc_class_len_get (lhs_class_expr);
+         if (rhs_ss->info
+             && rhs_ss->info->expr
+             && rhs_ss->info->expr->ts.type == BT_CHARACTER)
+           tmp2 = build_int_cst (TREE_TYPE (tmp),
+                                 rhs_ss->info->expr->ts.kind);
+         else
+           tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+         gfc_add_modify (pre, tmp, tmp2);
+       }
+    }
+
+  return rhs_class_expr;
+}
+
+
+
 /* Generate code to create and initialize the descriptor for a temporary
    array.  This is used for both temporaries needed by the scalarizer, and
    functions returning arrays.  Adjusts the loop variables to be
@@ -1250,13 +1300,46 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
     {
       gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
       class_expr = build_fold_indirect_ref_loc (input_location, initial);
-      eltype = TREE_TYPE (class_expr);
-      eltype = gfc_get_element_type (eltype);
       /* Obtain the structure (class) expression.  */
-      class_expr = TREE_OPERAND (class_expr, 0);
+      class_expr = gfc_get_class_from_expr (class_expr);
       gcc_assert (class_expr);
     }
 
+  /* Otherwise, some expressions, such as class functions, arising from
+     dependency checking in assignments come here with class element type.
+     The descriptor can be obtained from the ss->info and then converted
+     to the class object.  */
+  if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
+    class_expr = get_class_info_from_ss (pre, ss, &eltype);
+
+  /* If the dynamic type is not available, use the declared type.  */
+  if (eltype && GFC_CLASS_TYPE_P (eltype))
+    eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
+
+  if (class_expr == NULL_TREE)
+    elemsize = fold_convert (gfc_array_index_type,
+                            TYPE_SIZE_UNIT (eltype));
+  else
+    {
+      /* Unlimited polymorphic entities are initialised with NULL vptr. They
+        can be tested for by checking if the len field is present. If so
+        test the vptr before using the vtable size.  */
+      tmp = gfc_class_vptr_get (class_expr);
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+                            logical_type_node,
+                            tmp, build_int_cst (TREE_TYPE (tmp), 0));
+      elemsize = fold_build3_loc (input_location, COND_EXPR,
+                                 gfc_array_index_type,
+                                 tmp,
+                                 gfc_class_vtab_size_get (class_expr),
+                                 gfc_index_zero_node);
+      elemsize = gfc_evaluate_now (elemsize, pre);
+      elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
+      /* Casting the data as a character of the dynamic length ensures that
+        assignment of elements works when needed.  */
+      eltype = gfc_get_character_type_len (1, elemsize);
+    }
+
   memset (from, 0, sizeof (from));
   memset (to, 0, sizeof (to));
 
@@ -1405,12 +1488,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
        }
     }
 
-  if (class_expr == NULL_TREE)
-    elemsize = fold_convert (gfc_array_index_type,
-                            TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  else
-    elemsize = gfc_class_vtab_size_get (class_expr);
-
   /* Get the size of the array.  */
   if (size && !callee_alloc)
     {
@@ -2122,6 +2199,7 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
   gfc_ref *ref;
   gfc_typespec *ts;
   mpz_t char_len;
+  gfc_se se;
 
   /* Don't bother if we already know the length is a constant.  */
   if (*len && INTEGER_CST_P (*len))
@@ -2167,6 +2245,19 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
        }
     }
 
+  /* A last ditch attempt that is sometimes needed for deferred characters.  */
+  if (!ts->u.cl->backend_decl)
+    {
+      gfc_init_se (&se, NULL);
+      if (expr->rank)
+       gfc_conv_expr_descriptor (&se, expr);
+      else
+       gfc_conv_expr (&se, expr);
+      gcc_assert (se.string_length != NULL_TREE);
+      gfc_add_block_to_block (block, &se.pre);
+      ts->u.cl->backend_decl = se.string_length;
+    }
+
   *len = ts->u.cl->backend_decl;
 }
 
@@ -2976,13 +3067,16 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
        }
       /* Also the data pointer.  */
       tmp = gfc_conv_array_data (se.expr);
-      /* If this is a variable or address of a variable we use it directly.
+      /* If this is a variable or address or a class array, use it directly.
          Otherwise we must evaluate it now to avoid breaking dependency
         analysis by pulling the expressions for elemental array indices
         inside the loop.  */
       if (!(DECL_P (tmp)
            || (TREE_CODE (tmp) == ADDR_EXPR
-               && DECL_P (TREE_OPERAND (tmp, 0)))))
+               && DECL_P (TREE_OPERAND (tmp, 0)))
+           || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+               && TREE_CODE (se.expr) == COMPONENT_REF
+               && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
        tmp = gfc_evaluate_now (tmp, block);
       info->data = tmp;
 
@@ -3439,18 +3533,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
   size = gfc_class_vtab_size_get (decl);
 
   /* For unlimited polymorphic entities then _len component needs to be
-     multiplied with the size.  If no _len component is present, then
-     gfc_class_len_or_zero_get () return a zero_node.  */
-  tmp = gfc_class_len_or_zero_get (decl);
-  if (!integer_zerop (tmp))
-    size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
-                       fold_convert (TREE_TYPE (index), size),
-                       fold_build2 (MAX_EXPR, TREE_TYPE (index),
-                                    fold_convert (TREE_TYPE (index), tmp),
-                                    fold_convert (TREE_TYPE (index),
-                                                  integer_one_node)));
-  else
-    size = fold_convert (TREE_TYPE (index), size);
+     multiplied with the size.  */
+  size = gfc_resize_class_size_with_len (&se->pre, decl, size);
+
+  size = fold_convert (TREE_TYPE (index), size);
 
   /* Build the address of the element.  */
   type = TREE_TYPE (TREE_TYPE (base));
@@ -3609,7 +3695,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
 
   if (ar->dimen == 0)
     {
-      gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
+      gcc_assert (ar->codimen || sym->attr.select_rank_temporary
+                 || (ar->as && ar->as->corank));
 
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
        se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
@@ -3665,8 +3752,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        }
     }
 
+  decl = se->expr;
+  if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED)
+    decl = sym->backend_decl;
+
   cst_offset = offset = gfc_index_zero_node;
-  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
+  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
 
   /* Calculate the offsets from all the dimensions.  Make sure to associate
      the final offset so that we form a chain of loop invariant summands.  */
@@ -3687,7 +3778,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
          indexse.expr = save_expr (indexse.expr);
 
          /* Lower bound.  */
-         tmp = gfc_conv_array_lbound (se->expr, n);
+         tmp = gfc_conv_array_lbound (decl, n);
          if (sym->attr.temporary)
            {
              gfc_init_se (&tmpse, se);
@@ -3711,7 +3802,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
             arrays.  */
          if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
            {
-             tmp = gfc_conv_array_ubound (se->expr, n);
+             tmp = gfc_conv_array_ubound (decl, n);
              if (sym->attr.temporary)
                {
                  gfc_init_se (&tmpse, se);
@@ -3734,7 +3825,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        }
 
       /* Multiply the index by the stride.  */
-      stride = gfc_conv_array_stride (se->expr, n);
+      stride = gfc_conv_array_stride (decl, n);
       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
                             indexse.expr, stride);
 
@@ -3749,6 +3840,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   /* A pointer array component can be detected from its field decl. Fix
      the descriptor, mark the resulting variable decl and pass it to
      build_array_ref.  */
+  decl = NULL_TREE;
   if (get_CFI_desc (sym, expr, &decl, ar))
     decl = build_fold_indirect_ref_loc (input_location, decl);
   if (!expr->ts.deferred && !sym->attr.codimension
@@ -3775,7 +3867,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        decl = sym->backend_decl;
     }
   else if (sym->ts.type == BT_CLASS)
-    decl = NULL_TREE;
+    {
+      if (UNLIMITED_POLY (sym))
+       {
+         gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+         gfc_init_se (&tmpse, NULL);
+         gfc_conv_expr (&tmpse, class_expr);
+         if (!se->class_vptr)
+           se->class_vptr = gfc_class_vptr_get (tmpse.expr);
+         gfc_free_expr (class_expr);
+         decl = tmpse.expr;
+       }
+      else
+       decl = NULL_TREE;
+    }
 
   se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
 }
@@ -6360,7 +6465,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
   if (flag_stack_arrays)
     {
       gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
-      space = build_decl (sym->declared_at.lb->location,
+      space = build_decl (gfc_get_location (&sym->declared_at),
                          VAR_DECL, create_tmp_var_name ("A"),
                          TREE_TYPE (TREE_TYPE (decl)));
       gfc_trans_vla_type_sizes (sym, &init);
@@ -6402,7 +6507,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
       tmp = fold_build1_loc (input_location, DECL_EXPR,
                             TREE_TYPE (space), space);
       gfc_add_expr_to_block (&init, tmp);
-      addr = fold_build1_loc (sym->declared_at.lb->location,
+      addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
                              ADDR_EXPR, TREE_TYPE (decl), space);
       gfc_add_modify (&init, decl, addr);
       gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
@@ -6460,8 +6565,14 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   if (sym->attr.optional || sym->attr.not_always_present)
     {
-      tmp = gfc_conv_expr_present (sym);
-      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+      tree nullify;
+      if (TREE_CODE (parm) != PARM_DECL)
+       nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+                                  parm, null_pointer_node);
+      else
+       nullify = build_empty_stmt (input_location);
+      tmp = gfc_conv_expr_present (sym, true);
+      stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
     }
 
   gfc_add_init_cleanup (block, stmt, NULL_TREE);
@@ -6780,9 +6891,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
                      && sym->attr.dummy));
   if (optional_arg)
     {
-      tmp = gfc_conv_expr_present (sym);
-      stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
-                          build_empty_stmt (input_location));
+      tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
+      zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+                                  tmpdesc, zero_init);
+      tmp = gfc_conv_expr_present (sym, true);
+      stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
     }
 
   /* Cleanup code.  */
@@ -6940,6 +7053,24 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
              tmp = gfc_build_array_ref (tmp, index, NULL);
              break;
 
+           case REF_INQUIRY:
+             switch (ref->u.i)
+               {
+               case INQUIRY_RE:
+                 tmp = fold_build1_loc (input_location, REALPART_EXPR,
+                                        TREE_TYPE (TREE_TYPE (tmp)), tmp);
+                 break;
+
+               case INQUIRY_IM:
+                 tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
+                                        TREE_TYPE (TREE_TYPE (tmp)), tmp);
+                 break;
+
+               default:
+                 break;
+               }
+             break;
+
            default:
              gcc_unreachable ();
              break;
@@ -6986,7 +7117,12 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
       e = gfc_constructor_first (expr->value.constructor)->expr;
 
       gfc_init_se (&tse, NULL);
+
+      /* Avoid evaluating trailing array references since all we need is
+        the string length.  */
       if (e->rank)
+       tse.descriptor_only = 1;
+      if (e->rank && e->expr_type != EXPR_VARIABLE)
        gfc_conv_expr_descriptor (&tse, e);
       else
        gfc_conv_expr (&tse, e);
@@ -7004,14 +7140,26 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
       gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
                      tse.string_length);
 
+      /* Make sure that deferred length components point to the hidden
+        string_length component.  */
+      if (TREE_CODE (tse.expr) == COMPONENT_REF
+         && TREE_CODE (tse.string_length) == COMPONENT_REF
+         && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
+       e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
+
       return;
 
     case EXPR_OP:
       get_array_charlen (expr->value.op.op1, se);
 
-      /* For parentheses the expression ts.u.cl is identical.  */
+      /* For parentheses the expression ts.u.cl should be identical.  */
       if (expr->value.op.op == INTRINSIC_PARENTHESES)
-       return;
+       {
+         if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
+           expr->ts.u.cl->backend_decl
+                       = expr->value.op.op1->ts.u.cl->backend_decl;
+         return;
+       }
 
       expr->ts.u.cl->backend_decl =
                gfc_create_var (gfc_charlen_type_node, "sln");
@@ -7174,7 +7322,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   tree desc;
   stmtblock_t block;
   tree start;
-  tree offset;
   int full;
   bool subref_array_target = false;
   bool deferred_array_component = false;
@@ -7245,6 +7392,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
        full = 1;
       else if (se->direct_byref)
        full = 0;
+      else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
+       full = 1;
+      else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
+       full = 0;
       else
        full = gfc_full_array_ref_p (info->ref, NULL);
 
@@ -7481,10 +7632,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       tree from;
       tree to;
       tree base;
-      bool onebased = false, rank_remap;
+      tree offset;
 
       ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
-      rank_remap = ss->dimen < ndim;
 
       if (se->want_coarray)
        {
@@ -7528,10 +7678,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
            gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
        }
 
-      /* If we have an array section or are assigning make sure that
-        the lower bound is 1.  References to the full
-        array should otherwise keep the original bounds.  */
-      if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
+      /* If we have an array section, are assigning  or passing an array
+        section argument make sure that the lower bound is 1.  References
+        to the full array should otherwise keep the original bounds.  */
+      if (!info->ref || info->ref->u.ar.type != AR_FULL)
        for (dim = 0; dim < loop.dimen; dim++)
          if (!integer_onep (loop.from[dim]))
            {
@@ -7595,8 +7745,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       if (tmp != NULL_TREE)
        gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
 
-      offset = gfc_index_zero_node;
-
       /* The following can be somewhat confusing.  We have two
          descriptors, a new one and the original array.
          {parm, parmtype, dim} refer to the new one.
@@ -7610,22 +7758,17 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       tmp = gfc_conv_descriptor_dtype (parm);
       gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
 
-      /* Set offset for assignments to pointer only to zero if it is not
-         the full array.  */
-      if ((se->direct_byref || se->use_offset)
-         && ((info->ref && info->ref->u.ar.type != AR_FULL)
-             || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
-       base = gfc_index_zero_node;
-      else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-       base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
-      else
-       base = NULL_TREE;
+      /* The 1st element in the section.  */
+      base = gfc_index_zero_node;
+
+      /* The offset from the 1st element in the section.  */
+      offset = gfc_index_zero_node;
 
       for (n = 0; n < ndim; n++)
        {
          stride = gfc_conv_array_stride (desc, n);
 
-         /* Work out the offset.  */
+         /* Work out the 1st element in the section.  */
          if (info->ref
              && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
            {
@@ -7645,13 +7788,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
                                 start, tmp);
          tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
                                 tmp, stride);
-         offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
-                                   offset, tmp);
+         base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+                                   base, tmp);
 
          if (info->ref
              && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
            {
-             /* For elemental dimensions, we only need the offset.  */
+             /* For elemental dimensions, we only need the 1st
+                element in the section.  */
              continue;
            }
 
@@ -7671,7 +7815,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
          from = loop.from[dim];
          to = loop.to[dim];
 
-         onebased = integer_onep (from);
          gfc_conv_descriptor_lbound_set (&loop.pre, parm,
                                          gfc_rank_cst[dim], from);
 
@@ -7685,35 +7828,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
                                    gfc_array_index_type,
                                    stride, info->stride[n]);
 
-         if ((se->direct_byref || se->use_offset)
-             && ((info->ref && info->ref->u.ar.type != AR_FULL)
-                 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
-           {
-             base = fold_build2_loc (input_location, MINUS_EXPR,
-                                     TREE_TYPE (base), base, stride);
-           }
-         else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
-           {
-             bool toonebased;
-             tmp = gfc_conv_array_lbound (desc, n);
-             toonebased = integer_onep (tmp);
-             // lb(arr) - from (- start + 1)
-             tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                                    TREE_TYPE (base), tmp, from);
-             if (onebased && toonebased)
-               {
-                 tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                                        TREE_TYPE (base), tmp, start);
-                 tmp = fold_build2_loc (input_location, PLUS_EXPR,
-                                        TREE_TYPE (base), tmp,
-                                        gfc_index_one_node);
-               }
-             tmp = fold_build2_loc (input_location, MULT_EXPR,
-                                    TREE_TYPE (base), tmp,
-                                    gfc_conv_array_stride (desc, n));
-             base = fold_build2_loc (input_location, PLUS_EXPR,
-                                    TREE_TYPE (base), tmp, base);
-           }
+         tmp = fold_build2_loc (input_location, MULT_EXPR,
+                                TREE_TYPE (offset), stride, from);
+         offset = fold_build2_loc (input_location, MINUS_EXPR,
+                                  TREE_TYPE (offset), offset, tmp);
 
          /* Store the new stride.  */
          gfc_conv_descriptor_stride_set (&loop.pre, parm,
@@ -7736,58 +7854,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
                                      gfc_index_zero_node);
       else
        /* Point the data pointer at the 1st element in the section.  */
-       gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+       gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
                                subref_array_target, expr);
 
-      /* Force the offset to be -1, when the lower bound of the highest
-        dimension is one and the symbol is present and is not a
-        pointer/allocatable or associated.  */
-      if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-          && !se->data_not_needed)
-         || (se->use_offset && base != NULL_TREE))
-       {
-         /* Set the offset depending on base.  */
-         tmp = rank_remap && !se->direct_byref ?
-               fold_build2_loc (input_location, PLUS_EXPR,
-                                gfc_array_index_type, base,
-                                offset)
-             : base;
-         gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
-       }
-      else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
-              && !se->data_not_needed
-              && (!rank_remap || se->use_offset))
-       {
-         gfc_conv_descriptor_offset_set (&loop.pre, parm,
-                                        gfc_conv_descriptor_offset_get (desc));
-       }
-      else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
-              && !se->data_not_needed
-              && gfc_expr_attr (expr).select_rank_temporary)
-       {
-         gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
-       }
-      else if (onebased && (!rank_remap || se->use_offset)
-         && expr->symtree
-         && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
-              && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
-         && !expr->symtree->n.sym->attr.allocatable
-         && !expr->symtree->n.sym->attr.pointer
-         && !expr->symtree->n.sym->attr.host_assoc
-         && !expr->symtree->n.sym->attr.use_assoc)
-       {
-         /* Set the offset to -1.  */
-         mpz_t minus_one;
-         mpz_init_set_si (minus_one, -1);
-         tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
-         gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
-       }
-      else
-       {
-         /* Only the callee knows what the correct offset it, so just set
-            it to zero here.  */
-         gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
-       }
+      gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
+
       desc = parm;
     }
 
@@ -8048,7 +8119,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
          /* The components shall be deallocated before their containing entity.  */
          gfc_prepend_expr_to_block (&se->post, tmp);
        }
-      if (expr->ts.type == BT_CHARACTER)
+      if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
        se->string_length = expr->ts.u.cl->backend_decl;
       if (size)
        array_parameter_size (se->expr, expr, size);
@@ -8132,8 +8203,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
         making the packing and unpacking operation visible to the
         optimizers.  */
 
-      if (g77 && optimize && !optimize_size && expr->expr_type == EXPR_VARIABLE
+      if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
          && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
+         && !(expr->symtree->n.sym->as
+              && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
          && (fsym == NULL || fsym->ts.type != BT_ASSUMED))
        {
          gfc_conv_subref_array_arg (se, expr, g77,
@@ -8670,14 +8743,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
       vref = gfc_build_array_ref (var, index, NULL);
 
-      if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
-         && !caf_enabled (caf_mode))
+      if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
        {
          tmp = build_fold_indirect_ref_loc (input_location,
                                             gfc_conv_array_data (dest));
          dref = gfc_build_array_ref (tmp, index, NULL);
          tmp = structure_alloc_comps (der_type, vref, dref, rank,
-                                      COPY_ALLOC_COMP, 0, args);
+                                      COPY_ALLOC_COMP, caf_mode, args);
        }
       else
        tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
@@ -8818,7 +8890,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
          cdesc = gfc_create_var (cdesc, "cdesc");
          DECL_ARTIFICIAL (cdesc) = 1;
-  
+
          gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
                          gfc_get_dtype_rank_type (1, tmp));
          gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
@@ -8829,7 +8901,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                                          gfc_index_one_node);
          gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
                                          gfc_index_zero_node, ubound);
-  
+
          if (attr->dimension)
            comp = gfc_conv_descriptor_data_get (comp);
          else
@@ -9107,10 +9179,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
              && (CLASS_DATA (c)->attr.allocatable
                  || CLASS_DATA (c)->attr.class_pointer))
            {
+             tree vptr_decl;
+
              /* Allocatable CLASS components.  */
              comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
                                      decl, cdecl, NULL_TREE);
 
+             vptr_decl = gfc_class_vptr_get (comp);
+
              comp = gfc_class_data_get (comp);
              if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
                gfc_conv_descriptor_data_set (&fnblock, comp,
@@ -9122,6 +9198,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                                         build_int_cst (TREE_TYPE (comp), 0));
                  gfc_add_expr_to_block (&fnblock, tmp);
                }
+
+             /* The dynamic type of a disassociated pointer or unallocated
+                allocatable variable is its declared type. An unlimited
+                polymorphic entity has no declared type.  */
+             if (!UNLIMITED_POLY (c))
+               {
+                 vtab = gfc_find_derived_vtab (c->ts.u.derived);
+                 if (!vtab->backend_decl)
+                    gfc_get_symbol_decl (vtab);
+                 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
+               }
+             else
+               tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
+
+             tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+                                        void_type_node, vptr_decl, tmp);
+             gfc_add_expr_to_block (&fnblock, tmp);
+
              cmp_has_alloc_comps = false;
            }
          /* Coarrays need the component to be nulled before the api-call
@@ -9291,21 +9385,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                 for the malloc call.  */
              if (UNLIMITED_POLY (c))
                {
-                 tree ctmp;
                  gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
                                  gfc_class_len_get (comp));
-
-                 size = gfc_evaluate_now (size, &tmpblock);
-                 tmp = gfc_class_len_get (comp);
-                 ctmp = fold_build2_loc (input_location, MULT_EXPR,
-                                         size_type_node, size,
-                                         fold_convert (size_type_node, tmp));
-                 tmp = fold_build2_loc (input_location, GT_EXPR,
-                                        logical_type_node, tmp,
-                                        build_zero_cst (TREE_TYPE (tmp)));
-                 size = fold_build3_loc (input_location, COND_EXPR,
-                                         size_type_node, tmp, ctmp, size);
-                 size = gfc_evaluate_now (size, &tmpblock);
+                 size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
                }
 
              /* Coarray component have to have the same allocation status and
@@ -9396,12 +9478,21 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
              else if (flag_coarray == GFC_FCOARRAY_LIB
                       && caf_in_coarray (caf_mode))
                {
-                 tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
-                                      : fold_build3_loc (input_location,
-                                                         COMPONENT_REF,
-                                                         pvoid_type_node, dest,
-                                                         c->caf_token,
-                                                         NULL_TREE);
+                 tree dst_tok;
+                 if (c->as)
+                   dst_tok = gfc_conv_descriptor_token (dcmp);
+                 else
+                   {
+                     /* For a scalar allocatable component the caf_token is
+                        the next component.  */
+                     if (!c->caf_token)
+                         c->caf_token = c->next->backend_decl;
+                     dst_tok = fold_build3_loc (input_location,
+                                                COMPONENT_REF,
+                                                pvoid_type_node, dest,
+                                                c->caf_token,
+                                                NULL_TREE);
+                   }
                  tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
                                                       ctype, rank);
                }
@@ -9745,7 +9836,7 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
   args.image_index = image_index;
   args.stat = stat;
   args.errmsg = errmsg;
-  args.errmsg = errmsg_len;
+  args.errmsg_len = errmsg_len;
 
   if (rank == 0)
     {
@@ -9815,7 +9906,7 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 }
 
 
-/* Recursively traverse an object of paramterized derived type, generating
+/* Recursively traverse an object of parameterized derived type, generating
    code to allocate parameterized components.  */
 
 tree
@@ -9831,7 +9922,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
   return res;
 }
 
-/* Recursively traverse an object of paramterized derived type, generating
+/* Recursively traverse an object of parameterized derived type, generating
    code to deallocate parameterized components.  */
 
 tree
@@ -9842,7 +9933,7 @@ gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
 }
 
 
-/* Recursively traverse a dummy of paramterized derived type to check the
+/* Recursively traverse a dummy of parameterized derived type to check the
    values of LEN parameters.  */
 
 tree
@@ -10082,6 +10173,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tree alloc_expr;
   tree size1;
   tree size2;
+  tree elemsize1;
+  tree elemsize2;
   tree array1;
   tree cond_null;
   tree cond;
@@ -10097,6 +10190,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tree jump_label2;
   tree neq_size;
   tree lbd;
+  tree class_expr2 = NULL_TREE;
   int n;
   int dim;
   gfc_array_spec * as;
@@ -10161,6 +10255,114 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
   array1 = gfc_conv_descriptor_data_get (desc);
 
+  if (expr2)
+    desc2 = rss->info->data.array.descriptor;
+  else
+    desc2 = NULL_TREE;
+
+  /* Get the old lhs element size for deferred character and class expr1.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      if (expr1->ts.u.cl->backend_decl
+         && VAR_P (expr1->ts.u.cl->backend_decl))
+       elemsize1 = expr1->ts.u.cl->backend_decl;
+      else
+       elemsize1 = lss->info->string_length;
+    }
+  else if (expr1->ts.type == BT_CLASS)
+    {
+      tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+      if (tmp == NULL_TREE)
+       tmp = gfc_get_class_from_gfc_expr (expr1);
+
+      if (tmp != NULL_TREE)
+       {
+         tmp2 = gfc_class_vptr_get (tmp);
+         cond = fold_build2_loc (input_location, NE_EXPR,
+                                 logical_type_node, tmp2,
+                                 build_int_cst (TREE_TYPE (tmp2), 0));
+         elemsize1 = gfc_class_vtab_size_get (tmp);
+         elemsize1 = fold_build3_loc (input_location, COND_EXPR,
+                                     gfc_array_index_type, cond,
+                                     elemsize1, gfc_index_zero_node);
+       }
+      else
+       elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+    }
+  else
+    elemsize1 = NULL_TREE;
+  if (elemsize1 != NULL_TREE)
+    elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
+
+  /* Get the new lhs size in bytes.  */
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      if (expr2->ts.deferred)
+       {
+         if (expr2->ts.u.cl->backend_decl
+             && VAR_P (expr2->ts.u.cl->backend_decl))
+           tmp = expr2->ts.u.cl->backend_decl;
+         else
+           tmp = rss->info->string_length;
+       }
+      else
+       {
+         tmp = expr2->ts.u.cl->backend_decl;
+         if (!tmp && expr2->expr_type == EXPR_OP
+             && expr2->value.op.op == INTRINSIC_CONCAT)
+           {
+             tmp = concat_str_length (expr2);
+             expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+           }
+         else if (!tmp && expr2->ts.u.cl->length)
+           {
+             gfc_se tmpse;
+             gfc_init_se (&tmpse, NULL);
+             gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
+                                 gfc_charlen_type_node);
+             tmp = tmpse.expr;
+             expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+           }
+         tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+       }
+
+      if (expr1->ts.u.cl->backend_decl
+         && VAR_P (expr1->ts.u.cl->backend_decl))
+       gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      else
+       gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+      if (expr1->ts.kind > 1)
+       tmp = fold_build2_loc (input_location, MULT_EXPR,
+                              TREE_TYPE (tmp),
+                              tmp, build_int_cst (TREE_TYPE (tmp),
+                                                  expr1->ts.kind));
+    }
+  else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+    {
+      tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+      tmp = fold_build2_loc (input_location, MULT_EXPR,
+                            gfc_array_index_type, tmp,
+                            expr1->ts.u.cl->backend_decl);
+    }
+  else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+  else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
+    {
+      tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+      if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
+       tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
+
+      if (tmp != NULL_TREE)
+       tmp = gfc_class_vtab_size_get (tmp);
+      else
+       tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
+    }
+  else
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+  elemsize2 = fold_convert (gfc_array_index_type, tmp);
+  elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
+
   /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
      deallocated if expr is an array of different shape or any of the
      corresponding length type parameter values of variable and expr
@@ -10180,6 +10382,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
                             rss->info->string_length);
       cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
                                   logical_type_node, tmp, cond_null);
+      cond_null= gfc_evaluate_now (cond_null, &fblock);
     }
   else
     cond_null= gfc_evaluate_now (cond_null, &fblock);
@@ -10228,6 +10431,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
       gfc_add_expr_to_block (&fblock, tmp);
     }
 
+  /* ...else if the element lengths are not the same also go to
+     setting the bounds and doing the reallocation.... */
+  if (elemsize1 != NULL_TREE)
+    {
+      cond = fold_build2_loc (input_location, NE_EXPR,
+                             logical_type_node,
+                             elemsize1, elemsize2);
+      tmp = build3_v (COND_EXPR, cond,
+                     build1_v (GOTO_EXPR, jump_label1),
+                     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&fblock, tmp);
+    }
+
   /* ....else jump past the (re)alloc code.  */
   tmp = build1_v (GOTO_EXPR, jump_label2);
   gfc_add_expr_to_block (&fblock, tmp);
@@ -10250,11 +10466,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   gfc_add_expr_to_block (&fblock, tmp);
 
   /* Get the rhs size and fix it.  */
-  if (expr2)
-    desc2 = rss->info->data.array.descriptor;
-  else
-    desc2 = NULL_TREE;
-
   size2 = gfc_index_one_node;
   for (n = 0; n < expr2->rank; n++)
     {
@@ -10369,69 +10580,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
        gfc_add_modify (&fblock, linfo->delta[dim], tmp);
     }
 
-  /* Get the new lhs size in bytes.  */
-  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
-    {
-      if (expr2->ts.deferred)
-       {
-         if (expr2->ts.u.cl->backend_decl
-             && VAR_P (expr2->ts.u.cl->backend_decl))
-           tmp = expr2->ts.u.cl->backend_decl;
-         else
-           tmp = rss->info->string_length;
-       }
-      else
-       {
-         tmp = expr2->ts.u.cl->backend_decl;
-         if (!tmp && expr2->expr_type == EXPR_OP
-             && expr2->value.op.op == INTRINSIC_CONCAT)
-           {
-             tmp = concat_str_length (expr2);
-             expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
-           }
-         else if (!tmp && expr2->ts.u.cl->length)
-           {
-             gfc_se tmpse;
-             gfc_init_se (&tmpse, NULL);
-             gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
-                                 gfc_charlen_type_node);
-             tmp = tmpse.expr;
-             expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
-           }
-         tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
-       }
-
-      if (expr1->ts.u.cl->backend_decl
-         && VAR_P (expr1->ts.u.cl->backend_decl))
-       gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
-      else
-       gfc_add_modify (&fblock, lss->info->string_length, tmp);
-
-      if (expr1->ts.kind > 1)
-       tmp = fold_build2_loc (input_location, MULT_EXPR,
-                              TREE_TYPE (tmp),
-                              tmp, build_int_cst (TREE_TYPE (tmp),
-                                                  expr1->ts.kind));
-    }
-  else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
-    {
-      tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
-      tmp = fold_build2_loc (input_location, MULT_EXPR,
-                            gfc_array_index_type, tmp,
-                            expr1->ts.u.cl->backend_decl);
-    }
-  else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
-    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
-  else
-    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
-  tmp = fold_convert (gfc_array_index_type, tmp);
-
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
-    gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+    gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
 
   size2 = fold_build2_loc (input_location, MULT_EXPR,
                           gfc_array_index_type,
-                          tmp, size2);
+                          elemsize2, size2);
   size2 = fold_convert (size_type_node, size2);
   size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
                           size2, size_one_node);
@@ -10452,27 +10606,47 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
       gfc_add_modify (&fblock, tmp,
                      gfc_get_dtype_rank_type (expr1->rank,type));
     }
-  else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+  else if (expr1->ts.type == BT_CLASS)
     {
       tree type;
       tmp = gfc_conv_descriptor_dtype (desc);
-      type = gfc_typenode_for_spec (&expr2->ts);
+
+      if (expr2->ts.type != BT_CLASS)
+       type = gfc_typenode_for_spec (&expr2->ts);
+      else
+       type = gfc_get_character_type_len (1, elemsize2);
+
       gfc_add_modify (&fblock, tmp,
                      gfc_get_dtype_rank_type (expr2->rank,type));
       /* Set the _len field as well...  */
-      tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
-      if (expr2->ts.type == BT_CHARACTER)
-       gfc_add_modify (&fblock, tmp,
-                       fold_convert (TREE_TYPE (tmp),
-                                     TYPE_SIZE_UNIT (type)));
-      else
-       gfc_add_modify (&fblock, tmp,
-                       build_int_cst (TREE_TYPE (tmp), 0));
+      if (UNLIMITED_POLY (expr1))
+       {
+         tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+         if (expr2->ts.type == BT_CHARACTER)
+           gfc_add_modify (&fblock, tmp,
+                           fold_convert (TREE_TYPE (tmp),
+                                         TYPE_SIZE_UNIT (type)));
+         else
+           gfc_add_modify (&fblock, tmp,
+                           build_int_cst (TREE_TYPE (tmp), 0));
+       }
       /* ...and the vptr.  */
       tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
-      tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
-      tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
-      gfc_add_modify (&fblock, tmp, tmp2);
+      if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+         && TREE_CODE (desc2) == COMPONENT_REF)
+       {
+         tmp2 = gfc_get_class_from_expr (desc2);
+         tmp2 = gfc_class_vptr_get (tmp2);
+       }
+      else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+       tmp2 = gfc_class_vptr_get (class_expr2);
+      else
+       {
+         tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+         tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+       }
+
+      gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
     }
   else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
     {
@@ -10548,11 +10722,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   gfc_add_block_to_block (&realloc_block, &caf_se.post);
   realloc_expr = gfc_finish_block (&realloc_block);
 
-  /* Only reallocate if sizes are different.  */
+  /* Reallocate if sizes or dynamic types are different.  */
+  if (elemsize1)
+    {
+      tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+                            elemsize1, elemsize2);
+      tmp = gfc_evaluate_now (tmp, &fblock);
+      neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+                                 logical_type_node, neq_size, tmp);
+    }
   tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
                  build_empty_stmt (input_location));
-  realloc_expr = tmp;
 
+  realloc_expr = tmp;
 
   /* Malloc expression.  */
   gfc_init_block (&alloc_block);
@@ -10599,11 +10781,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   alloc_expr = gfc_finish_block (&alloc_block);
 
   /* Malloc if not allocated; realloc otherwise.  */
-  tmp = build_int_cst (TREE_TYPE (array1), 0);
-  cond = fold_build2_loc (input_location, EQ_EXPR,
-                         logical_type_node,
-                         array1, tmp);
-  tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+  tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
   gfc_add_expr_to_block (&fblock, tmp);
 
   /* Make sure that the scalarizer data pointer is updated.  */
@@ -10613,7 +10791,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
       gfc_add_modify (&fblock, linfo->data, tmp);
     }
 
-  /* Add the exit label.  */
+  /* Add the label for same shape lhs and rhs.  */
   tmp = build1_v (LABEL_EXPR, jump_label2);
   gfc_add_expr_to_block (&fblock, tmp);
 
@@ -10623,7 +10801,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 
 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
    Do likewise, recursively if necessary, with the allocatable components of
-   derived types.  */
+   derived types.  This function is also called for assumed-rank arrays, which
+   are always dummy arguments.  */
 
 void
 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
@@ -10645,7 +10824,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   /* Make sure the frontend gets these right.  */
   gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
-             || has_finalizer);
+             || has_finalizer
+             || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
 
   gfc_save_backend_locus (&loc);
   gfc_set_backend_locus (&sym->declared_at);
@@ -10819,7 +10999,8 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
       if (ref->type == REF_SUBSTRING)
        {
          ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
-         ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
+         if (ref->u.ss.end)
+           ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
        }
 
       /* We're only interested in array sections from now on.  */