re PR fortran/34640 (ICE when assigning item of a derived-component to a pointer)

2017-09-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34640
	PR fortran/40737
	PR fortran/55763
	PR fortran/57019
	PR fortran/57116

	* expr.c (is_subref_array): Add class pointer array dummies
	to the list of expressions that return true.
	* trans-array.c: Add SPAN_FIELD and update indices for
	subsequent fields.
	(gfc_conv_descriptor_span, gfc_conv_descriptor_span_get,
	gfc_conv_descriptor_span_set, is_pointer_array,
	get_array_span): New functions.
	(gfc_get_descriptor_offsets_for_info): New function to preserve
	API for access to descriptor fields for trans-types.c.
	(gfc_conv_scalarized_array_ref): If the expression is a subref
	array, make sure that info->descriptor is a descriptor type.
	Otherwise, if info->descriptor is a pointer array, set 'decl'
	and fix it if it is a component reference.
	(build_array_ref): Simplify handling of class array refs by
	passing the vptr to gfc_build_array_ref rather than generating
	the pointer arithmetic in this function.
	(gfc_conv_array_ref): As in gfc_conv_scalarized_array_ref, set
	'decl'.
	(gfc_array_allocate): Set the span field if this is a pointer
	array. Use the expr3 element size if it is available, so that
	the dynamic type element size is used.
	(gfc_conv_expr_descriptor): Set the span field for pointer
	assignments.
	* trans-array.h: Prototypes for gfc_conv_descriptor_span_get
	gfc_conv_descriptor_span_set and
	gfc_get_descriptor_offsets_for_info added.
	trans-decl.c (gfc_get_symbol_decl): If a non-class pointer
	array, mark the declaration as a GFC_DECL_PTR_ARRAY_P. Remove
	the setting of GFC_DECL_SPAN.
	(gfc_trans_deferred_vars): Set the span field to zero in thge
	originating scope.
	* trans-expr.c (gfc_conv_procedure_call): Do not use copy-in/
	copy-out to pass subref expressions to a pointer dummy.
	(gfc_trans_pointer_assignment): Remove code for setting of
	GFC_DECL_SPAN. Set the 'span' field for non-class pointers to
	class function results. Likewise for rank remap. In the case
	that the target is not a whole array, use the target array ref
	for remap and, since the 'start' indices are missing, set the
	lbounds to one, as required by the standard.
	* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Pick up the
	'token' offset from the field decl in the descriptor.
	(conv_isocbinding_subroutine): Set the 'span' field.
	* trans-io.c (gfc_trans_transfer): Always scalarize pointer
	array io.
	* trans-stmt.c (trans_associate_var): Set the 'span' field.
	* trans-types.c (gfc_get_array_descriptor_base): Add the 'span'
	field to the array descriptor.
	(gfc_get_derived_type): Pointer array components are marked as
	GFC_DECL_PTR_ARRAY_P.
	(gfc_get_array_descr_info): Replaced API breaking code for
	descriptor offset calling gfc_get_descriptor_offsets_for_info.
	* trans.c (get_array_span): New function.
	(gfc_build_array_ref): Simplify by calling get_array_span and
	obtain 'span' if 'decl' or 'vptr' present.
	* trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
	as GFC_DECL_PTR_ARRAY_P.


2017-09-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34640
	* gfortran.dg/associate_24.f90: New test.
	* gfortran.dg/assumed_type_2.f90: Adjust some of the tree dump
	checks.
	* gfortran.dg/no_arg_check_2.f90: Likewise.
	* gfortran.dg/pointer_array_1.f90: New test.
	* gfortran.dg/pointer_array_2.f90: New test.
	* gfortran.dg/pointer_array_7.f90: New test.
	* gfortran.dg/pointer_array_8.f90: New test.
	* gfortran.dg/pointer_array_component_1.f90: New test.
	* gfortran.dg/pointer_array_component_2.f90: New test.
	* gfortran.dg/goacc/kernels-alias-4.f95: Bump up both tree scan
	counts by 1.

	PR fortran/40737
	* gfortran.dg/pointer_array_3.f90: New test.

	PR fortran/57116
	* gfortran.dg/pointer_array_4.f90: New test.

	PR fortran/55763
	* gfortran.dg/pointer_array_5.f90: New test.

	PR fortran/57019
	* gfortran.dg/pointer_array_6.f90: New test.

2017-09-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34640
	* libgfortran/libgfortran.h: Add span field to descriptor.
	* libgfortran/libtool-version : Bump up version number to 5:0:0.

From-SVN: r251949

30 files changed, 1202 insertions, 179 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 140caf5..20fae5a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,68 @@
+2017-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34640
+	PR fortran/40737
+	PR fortran/55763
+	PR fortran/57019
+	PR fortran/57116
+
+	* expr.c (is_subref_array): Add class pointer array dummies
+	to the list of expressions that return true.
+	* trans-array.c: Add SPAN_FIELD and update indices for
+	subsequent fields.
+	(gfc_conv_descriptor_span, gfc_conv_descriptor_span_get,
+	gfc_conv_descriptor_span_set, is_pointer_array,
+	get_array_span): New functions.
+	(gfc_get_descriptor_offsets_for_info): New function to preserve
+	API for access to descriptor fields for trans-types.c.
+	(gfc_conv_scalarized_array_ref): If the expression is a subref
+	array, make sure that info->descriptor is a descriptor type.
+	Otherwise, if info->descriptor is a pointer array, set 'decl'
+	and fix it if it is a component reference.
+	(build_array_ref): Simplify handling of class array refs by
+	passing the vptr to gfc_build_array_ref rather than generating
+	the pointer arithmetic in this function.
+	(gfc_conv_array_ref): As in gfc_conv_scalarized_array_ref, set
+	'decl'.
+	(gfc_array_allocate): Set the span field if this is a pointer
+	array. Use the expr3 element size if it is available, so that
+	the dynamic type element size is used.
+	(gfc_conv_expr_descriptor): Set the span field for pointer
+	assignments.
+	* trans-array.h: Prototypes for gfc_conv_descriptor_span_get
+	gfc_conv_descriptor_span_set and
+	gfc_get_descriptor_offsets_for_info added.
+	trans-decl.c (gfc_get_symbol_decl): If a non-class pointer
+	array, mark the declaration as a GFC_DECL_PTR_ARRAY_P. Remove
+	the setting of GFC_DECL_SPAN.
+	(gfc_trans_deferred_vars): Set the span field to zero in thge
+	originating scope.
+	* trans-expr.c (gfc_conv_procedure_call): Do not use copy-in/
+	copy-out to pass subref expressions to a pointer dummy.
+	(gfc_trans_pointer_assignment): Remove code for setting of
+	GFC_DECL_SPAN. Set the 'span' field for non-class pointers to
+	class function results. Likewise for rank remap. In the case
+	that the target is not a whole array, use the target array ref
+	for remap and, since the 'start' indices are missing, set the
+	lbounds to one, as required by the standard.
+	* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Pick up the
+	'token' offset from the field decl in the descriptor.
+	(conv_isocbinding_subroutine): Set the 'span' field.
+	* trans-io.c (gfc_trans_transfer): Always scalarize pointer
+	array io.
+	* trans-stmt.c (trans_associate_var): Set the 'span' field.
+	* trans-types.c (gfc_get_array_descriptor_base): Add the 'span'
+	field to the array descriptor.
+	(gfc_get_derived_type): Pointer array components are marked as
+	GFC_DECL_PTR_ARRAY_P.
+	(gfc_get_array_descr_info): Replaced API breaking code for
+	descriptor offset calling gfc_get_descriptor_offsets_for_info.
+	* trans.c (get_array_span): New function.
+	(gfc_build_array_ref): Simplify by calling get_array_span and
+	obtain 'span' if 'decl' or 'vptr' present.
+	* trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
+	as GFC_DECL_PTR_ARRAY_P.
+
 2017-09-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	* decl.c : Add decl_type_param_list, type_param_spec_list as
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 079a2ba..35df29c 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -995,6 +995,11 @@ is_subref_array (gfc_expr * e)
   if (e->symtree->n.sym->attr.subref_array_pointer)
     return true;
 
+  if (e->symtree->n.sym->ts.type == BT_CLASS
+      && e->symtree->n.sym->attr.dummy
+      && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
+    return true;
+
   seen_array = false;
   for (ref = e->ref; ref; ref = ref->next)
     {
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 2b06903..328da4e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -125,8 +125,9 @@ gfc_array_dataptr_type (tree desc)
 #define DATA_FIELD 0
 #define OFFSET_FIELD 1
 #define DTYPE_FIELD 2
-#define DIMENSION_FIELD 3
-#define CAF_TOKEN_FIELD 4
+#define SPAN_FIELD 3
+#define DIMENSION_FIELD 4
+#define CAF_TOKEN_FIELD 5
 
 #define STRIDE_SUBFIELD 0
 #define LBOUND_SUBFIELD 1
@@ -244,6 +245,36 @@ gfc_conv_descriptor_dtype (tree desc)
 			  desc, field, NULL_TREE);
 }
 
+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
+gfc_conv_descriptor_span_get (tree desc)
+{
+  return gfc_conv_descriptor_span (desc);
+}
+
+void
+gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
+				tree value)
+{
+  tree t = gfc_conv_descriptor_span (desc);
+  gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
 
 tree
 gfc_conv_descriptor_rank (tree desc)
@@ -466,11 +497,41 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
 }
 
 
+/* Obtain offsets for trans-types.c(gfc_get_array_descr_info).  */
+
+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 field;
+  tree type;
+
+  type = TYPE_MAIN_VARIANT (desc_type);
+  field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
+  *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), DIMENSION_FIELD);
+  *dim_off = byte_position (field);
+  type = TREE_TYPE (TREE_TYPE (field));
+  *dim_size = TYPE_SIZE_UNIT (type);
+  field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
+  *stride_suboff = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
+  *lower_suboff = byte_position (field);
+  field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
+  *upper_suboff = byte_position (field);
+}
+
+
 /* Cleanup those #defines.  */
 
 #undef DATA_FIELD
 #undef OFFSET_FIELD
 #undef DTYPE_FIELD
+#undef SPAN_FIELD
 #undef DIMENSION_FIELD
 #undef CAF_TOKEN_FIELD
 #undef STRIDE_SUBFIELD
@@ -720,6 +781,84 @@ gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
 }
 
 
+/* Returns true if the expression is an array pointer.  */
+
+static bool
+is_pointer_array (tree expr)
+{
+  if (flag_openmp)
+    return false;
+
+  if (expr == NULL_TREE
+      || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
+      || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
+    return false;
+
+  if (TREE_CODE (expr) == VAR_DECL
+      && GFC_DECL_PTR_ARRAY_P (expr))
+    return true;
+
+  if (TREE_CODE (expr) == PARM_DECL
+      && GFC_DECL_PTR_ARRAY_P (expr))
+    return true;
+
+  if (TREE_CODE (expr) == INDIRECT_REF
+      && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
+    return true;
+
+  /* The field declaration is marked as an pointer array.  */
+  if (TREE_CODE (expr) == COMPONENT_REF
+      && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
+      && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
+    return true;
+
+  return false;
+}
+
+
+/* Return the span of an array.  */
+
+static tree
+get_array_span (tree desc, gfc_expr *expr)
+{
+  tree tmp;
+
+  if (is_pointer_array (desc))
+    /* This will have the span field set.  */
+    tmp = gfc_conv_descriptor_span_get (desc);
+  else if (TREE_CODE (desc) == COMPONENT_REF
+	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+	   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+    {
+      /* The descriptor is a class _data field and so use the vtable
+	 size for the receiving span field.  */
+      tmp = gfc_get_vptr_from_expr (desc);
+      tmp = gfc_vptr_size_get (tmp);
+    }
+  else if (expr && expr->expr_type == EXPR_VARIABLE
+	   && expr->symtree->n.sym->ts.type == BT_CLASS
+	   && expr->ref->type == REF_COMPONENT
+	   && expr->ref->next->type == REF_ARRAY
+	   && expr->ref->next->next == NULL
+	   && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
+    {
+      /* Dummys come in sometimes with the descriptor detached from
+	 the class field or declaration.  */
+      tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
+      tmp = gfc_vptr_size_get (tmp);
+    }
+  else
+    {
+      /* If none of the fancy stuff works, the span is the element
+	 size of the array.  */
+      tmp = gfc_get_element_type (TREE_TYPE (desc));
+      tmp = fold_convert (gfc_array_index_type,
+			  size_in_bytes (tmp));
+    }
+  return tmp;
+}
+
+
 /* Generate an initializer for a static pointer or allocatable array.  */
 
 void
@@ -3239,11 +3378,30 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
     index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 			     index, info->offset);
 
-  if (expr && (is_subref_array (expr)
+  if (expr && ((is_subref_array (expr)
+		&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
 	       || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
 					 || expr->expr_type == EXPR_FUNCTION))))
     decl = expr->symtree->n.sym->backend_decl;
 
+  /* A pointer array component can be detected from its field decl. Fix
+     the descriptor, mark the resulting variable decl and pass it to
+     gfc_build_array_ref.  */
+  if (is_pointer_array (info->descriptor))
+    {
+      if (TREE_CODE (info->descriptor) == COMPONENT_REF)
+	{
+	  decl = gfc_evaluate_now (info->descriptor, &se->pre);
+	  GFC_DECL_PTR_ARRAY_P (decl) = 1;
+	  TREE_USED (decl) = 1;
+	}
+      else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
+	decl = TREE_OPERAND (info->descriptor, 0);
+
+      if (decl == NULL_TREE)
+	decl = info->descriptor;
+    }
+
   tmp = build_fold_indirect_ref_loc (input_location, info->data);
 
   /* Use the vptr 'size' field to access a class the element of a class
@@ -3288,45 +3446,27 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
 {
   tree tmp;
   tree type;
-  tree cdecl;
-  bool classarray = false;
+  tree cdesc;
 
   /* For class arrays the class declaration is stored in the saved
      descriptor.  */
   if (INDIRECT_REF_P (desc)
       && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
       && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
-    cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
+    cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
 				  TREE_OPERAND (desc, 0)));
   else
-    cdecl = desc;
+    cdesc = desc;
 
   /* Class container types do not always have the GFC_CLASS_TYPE_P
      but the canonical type does.  */
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
-      && TREE_CODE (cdecl) == COMPONENT_REF)
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
+      && TREE_CODE (cdesc) == COMPONENT_REF)
     {
-      type = TREE_TYPE (TREE_OPERAND (cdecl, 0));
+      type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
       if (TYPE_CANONICAL (type)
 	  && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
-	{
-	  type = TREE_TYPE (desc);
-	  classarray = true;
-	}
-    }
-  else
-    type = NULL;
-
-  /* Class array references need special treatment because the assigned
-     type size needs to be used to point to the element.  */
-  if (classarray)
-    {
-      type = gfc_get_element_type (type);
-      tmp = TREE_OPERAND (cdecl, 0);
-      tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
-      tmp = fold_convert (build_pointer_type (type), tmp);
-      tmp = build_fold_indirect_ref_loc (input_location, tmp);
-      return tmp;
+	vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
     }
 
   tmp = gfc_conv_array_data (desc);
@@ -3350,6 +3490,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   tree offset, cst_offset;
   tree tmp;
   tree stride;
+  tree decl = NULL_TREE;
   gfc_se indexse;
   gfc_se tmpse;
   gfc_symbol * sym = expr->symtree->n.sym;
@@ -3494,8 +3635,31 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
     offset = fold_build2_loc (input_location, PLUS_EXPR,
 			      gfc_array_index_type, offset, cst_offset);
 
-  se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ?
-				NULL_TREE : sym->backend_decl, se->class_vptr);
+  /* 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.  */
+  if (!expr->ts.deferred && !sym->attr.codimension
+      && is_pointer_array (se->expr))
+    {
+      if (TREE_CODE (se->expr) == COMPONENT_REF)
+	{
+	  decl = gfc_evaluate_now (se->expr, &se->pre);
+	  GFC_DECL_PTR_ARRAY_P (decl) = 1;
+	  TREE_USED (decl) = 1;
+	}
+      else if (TREE_CODE (se->expr) == INDIRECT_REF)
+	decl = TREE_OPERAND (se->expr, 0);
+      else
+	decl = se->expr;
+    }
+  else if (expr->ts.deferred
+	   || (sym->ts.type == BT_CHARACTER
+	       && sym->attr.select_type_temporary))
+    decl = sym->backend_decl;
+  else if (sym->ts.type == BT_CLASS)
+    decl = NULL_TREE;
+
+  se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
 }
 
 
@@ -5651,6 +5815,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   if (dimension)
     gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
 
+  /* Pointer arrays need the span field to be set.  */
+  if (is_pointer_array (se->expr)
+      || (expr->ts.type == BT_CLASS
+	  && CLASS_DATA (expr)->attr.class_pointer))
+    {
+      if (expr3 && expr3_elem_size != NULL_TREE)
+	tmp = expr3_elem_size;
+      else
+	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr)));
+      tmp = fold_convert (gfc_array_index_type, tmp);
+      gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
+    }
+
   set_descriptor = gfc_finish_block (&set_descriptor_block);
   if (status != NULL_TREE)
     {
@@ -6854,6 +7031,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	      /* Add any offsets from subreferences.  */
 	      gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
 				      subref_array_target, expr);
+
+	      /* ....and set the span field.  */
+	      tmp = get_array_span (desc, expr);
+	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
 	    }
 	  else if (se->want_pointer)
 	    {
@@ -6889,8 +7070,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    se->ss = ss;
 	  else
 	    gcc_assert (se->ss == ss);
+
+	  if (!is_pointer_array (se->expr))
+	    {
+	      tmp = gfc_get_element_type (TREE_TYPE (se->expr));
+	      tmp = fold_convert (gfc_array_index_type,
+				  size_in_bytes (tmp));
+	      gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
+	    }
+
 	  se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 	  gfc_conv_expr (se, expr);
+
 	  gfc_free_ss_chain (ss);
 	  return;
 	}
@@ -7110,9 +7301,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       desc = info->descriptor;
       if (se->direct_byref && !se->byref_noassign)
 	{
-	  /* For pointer assignments we fill in the destination.  */
+	  /* For pointer assignments we fill in the destination....  */
 	  parm = se->expr;
 	  parmtype = TREE_TYPE (parm);
+
+	  /* ....and set the span field.  */
+	  tmp = get_array_span (desc, expr);
+	  gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
 	}
       else
 	{
@@ -7585,6 +7780,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       /* Every other type of array.  */
       se->want_pointer = 1;
       gfc_conv_expr_descriptor (se, expr);
+
       if (size)
 	array_parameter_size (build_fold_indirect_ref_loc (input_location,
 						       se->expr),
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3cc08b3..e2a8737 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -156,9 +156,13 @@ tree gfc_conv_array_ubound (tree, int);
 void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
 
 /* Build expressions for accessing components of an array descriptor.  */
+void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tree *,
+					  tree *, tree *, tree *);
+
 tree gfc_conv_descriptor_data_get (tree);
 tree gfc_conv_descriptor_data_addr (tree);
 tree gfc_conv_descriptor_offset_get (tree);
+tree gfc_conv_descriptor_span_get (tree);
 tree gfc_conv_descriptor_dtype (tree);
 tree gfc_conv_descriptor_rank (tree);
 tree gfc_get_descriptor_dimension (tree);
@@ -169,6 +173,7 @@ tree gfc_conv_descriptor_token (tree);
 
 void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
 void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_span_set (stmtblock_t *, tree, tree);
 void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 30477c2..830c53a 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1532,6 +1532,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       /* Dummy variables should already have been created.  */
       gcc_assert (sym->backend_decl);
 
+      if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
+	GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
+
       /* Create a character length variable.  */
       if (sym->ts.type == BT_CHARACTER)
 	{
@@ -1766,27 +1769,18 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   if (sym->ts.type == BT_CHARACTER)
     /* Character variables need special handling.  */
     gfc_allocate_lang_decl (decl);
-  else if (sym->attr.subref_array_pointer)
-    /* We need the span for these beasts.  */
-    gfc_allocate_lang_decl (decl);
 
-  if (sym->attr.subref_array_pointer)
-    {
-      tree span;
-      GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
-      span = build_decl (input_location,
-			 VAR_DECL, create_tmp_var_name ("span"),
-			 gfc_array_index_type);
-      gfc_finish_var_decl (span, sym);
-      TREE_STATIC (span) = TREE_STATIC (decl);
-      DECL_ARTIFICIAL (span) = 1;
+  if (sym->assoc && sym->attr.subref_array_pointer)
+    sym->attr.pointer = 1;
 
-      GFC_DECL_SPAN (decl) = span;
-      GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
-    }
+  if (sym->attr.pointer && sym->attr.dimension
+      && !sym->ts.deferred
+      && !(sym->attr.select_type_temporary
+	   && !sym->attr.subref_array_pointer))
+    GFC_DECL_PTR_ARRAY_P (decl) = 1;
 
   if (sym->ts.type == BT_CLASS)
-	GFC_DECL_CLASS(decl) = 1;
+    GFC_DECL_CLASS(decl) = 1;
 
   sym->backend_decl = decl;
 
@@ -4347,13 +4341,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	    }
 	}
 
-      if (sym->attr.subref_array_pointer
-	  && GFC_DECL_SPAN (sym->backend_decl)
-	  && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
+      if (sym->attr.pointer && sym->attr.dimension
+	  && !sym->attr.use_assoc
+	  && !sym->attr.host_assoc
+	  && !sym->attr.dummy
+	  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
 	{
 	  gfc_init_block (&tmpblock);
-	  gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
-			  build_int_cst (gfc_array_index_type, 0));
+	  gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
+				build_int_cst (gfc_array_index_type, 0));
 	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
 				NULL_TREE);
 	}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b310458..8c8569f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5413,7 +5413,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      if (e->expr_type == EXPR_VARIABLE
-		    && is_subref_array (e))
+		    && is_subref_array (e)
+		    && !(fsym && fsym->attr.pointer))
 		/* The actual argument is a component reference to an
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
@@ -8223,7 +8224,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   stmtblock_t block;
   tree desc;
   tree tmp;
-  tree decl;
   bool scalar, non_proc_pointer_assign;
   gfc_ss *ss;
 
@@ -8412,30 +8412,24 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_conv_expr_descriptor (&lse, expr2);
 	  strlen_rhs = lse.string_length;
 
-	  /* If this is a subreference array pointer assignment, use the rhs
-	     descriptor element size for the lhs span.  */
-	  if (expr1->symtree->n.sym->attr.subref_array_pointer)
-	    {
-	      decl = expr1->symtree->n.sym->backend_decl;
-	      gfc_init_se (&rse, NULL);
-	      rse.descriptor_only = 1;
-	      gfc_conv_expr (&rse, expr2);
-	      if (expr1->ts.type == BT_CLASS)
-		trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
-						 NULL, NULL);
-	      tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
-	      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
-	      if (!INTEGER_CST_P (tmp))
-		gfc_add_block_to_block (&lse.post, &rse.pre);
-	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
-	    }
-	  else if (expr1->ts.type == BT_CLASS)
+	  if (expr1->ts.type == BT_CLASS)
 	    {
 	      rse.expr = NULL_TREE;
 	      rse.string_length = NULL_TREE;
 	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
 					       NULL, NULL);
 	    }
+
+	  if (remap == NULL)
+	    {
+	      /* If the target is not a whole array, use the target array
+		 reference for remap.  */
+	      for (remap = expr2->ref; remap; remap = remap->next)
+		if (remap->type == REF_ARRAY
+		    && remap->u.ar.type == AR_FULL
+		    && remap->next)
+		  break;
+	    }
 	}
       else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
 	{
@@ -8446,7 +8440,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      rse.expr = gfc_class_data_get (rse.expr);
 	      gfc_add_modify (&lse.pre, desc, rse.expr);
-	    }
+	      /* Set the lhs span.  */
+	      tmp = TREE_TYPE (rse.expr);
+	      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+	      tmp = fold_convert (gfc_array_index_type, tmp);
+	      gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
+ 	    }
 	  else
 	    {
 	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
@@ -8492,7 +8491,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 		 converted in rse and now have to build the correct LHS
 		 descriptor for it.  */
 
-	      tree dtype, data;
+	      tree dtype, data, span;
 	      tree offs, stride;
 	      tree lbound, ubound;
 
@@ -8505,6 +8504,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      data = gfc_conv_descriptor_data_get (rse.expr);
 	      gfc_conv_descriptor_data_set (&block, desc, data);
 
+	      /* Copy the span.  */
+	      if (TREE_CODE (rse.expr) == VAR_DECL
+		  && GFC_DECL_PTR_ARRAY_P (rse.expr))
+		span = gfc_conv_descriptor_span_get (rse.expr);
+	      else
+		{
+		  tmp = TREE_TYPE (rse.expr);
+		  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+		  span = fold_convert (gfc_array_index_type, tmp);
+		}
+	      gfc_conv_descriptor_span_set (&block, desc, span);
+
 	      /* Copy offset but adjust it such that it would correspond
 		 to a lbound of zero.  */
 	      offs = gfc_conv_descriptor_offset_get (rse.expr);
@@ -8586,12 +8597,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 		{
 		  gfc_se lbound_se;
 
-		  gcc_assert (remap->u.ar.start[dim]);
 		  gcc_assert (!remap->u.ar.end[dim]);
 		  gfc_init_se (&lbound_se, NULL);
-		  gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
-
-		  gfc_add_block_to_block (&block, &lbound_se.pre);
+		  if (remap->u.ar.start[dim])
+		    {
+		      gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
+		      gfc_add_block_to_block (&block, &lbound_se.pre);
+		    }
+		  else
+		    /* This remap arises from a target that is not a whole
+		       array. The start expressions will be NULL but we need
+		       the lbounds to be one.  */
+		    lbound_se.expr = gfc_index_one_node;
 		  gfc_conv_shift_descriptor_lbound (&block, desc,
 						    dim, lbound_se.expr);
 		  gfc_add_block_to_block (&block, &lbound_se.post);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3c9e1d5..9bc465e 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1225,10 +1225,9 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
 	      && ref->u.c.component->attr.dimension)
 	    {
 	      tree arr_desc_token_offset;
-	      /* Get the token from the descriptor.  */
-	      arr_desc_token_offset = gfc_advance_chain (
-		    TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)),
-		    4 /* CAF_TOKEN_FIELD  */);
+	      /* Get the token field from the descriptor.  */
+	      arr_desc_token_offset = TREE_OPERAND (
+		    gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
 	      arr_desc_token_offset
 		  = compute_component_offset (arr_desc_token_offset,
 					      TREE_TYPE (tmp));
@@ -8129,6 +8128,11 @@ conv_isocbinding_subroutine (gfc_code *code)
   gfc_add_block_to_block (&block, &fptrse.pre);
   desc = fptrse.expr;
 
+  /* Set the span field.  */
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+  tmp = fold_convert (gfc_array_index_type, tmp);
+  gfc_conv_descriptor_span_set (&block, desc, tmp);
+
   /* Set data value, dtype, and offset.  */
   tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
   gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index aa974eb..026f9a9 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2569,6 +2569,12 @@ gfc_trans_transfer (gfc_code * code)
 	  gcc_assert (ref && ref->type == REF_ARRAY);
 	}
 
+      if (expr->ts.type != BT_CLASS
+	 && expr->expr_type == EXPR_VARIABLE
+	 && gfc_expr_attr (expr).pointer)
+	goto scalarize;
+
+
       if (!(gfc_bt_struct (expr->ts.type)
 	      || expr->ts.type == BT_CLASS)
 	    && ref && ref->next == NULL
@@ -2603,6 +2609,7 @@ gfc_trans_transfer (gfc_code * code)
 	  goto finish_block_label;
 	}
 
+scalarize:
       /* Initialize the scalarizer.  */
       ss = gfc_walk_expr (expr);
       gfc_init_loopinfo (&loop);
@@ -2618,7 +2625,9 @@ gfc_trans_transfer (gfc_code * code)
 
       gfc_copy_loopinfo_to_se (&se, &loop);
       se.ss = ss;
+
       gfc_conv_expr_reference (&se, expr);
+
       if (expr->ts.type == BT_CLASS)
 	vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
       else
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6a407f9..925ea63 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1531,6 +1531,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   int n;
   tree charlen;
   bool need_len_assign;
+  bool whole_array = true;
+  gfc_ref *ref;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1541,6 +1543,15 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
   unlimited = UNLIMITED_POLY (e);
 
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY
+	&& ref->u.ar.type == AR_FULL
+	&& ref->next)
+      {
+	whole_array =  false;
+	break;
+      }
+
   /* Assignments to the string length need to be generated, when
      ( sym is a char array or
        sym has a _len component)
@@ -1583,11 +1594,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
       /* If we didn't already do the pointer assignment, set associate-name
 	 descriptor to the one generated for the temporary.  */
-      if (!sym->assoc->variable && !cst_array_ctor)
+      if ((!sym->assoc->variable && !cst_array_ctor)
+	  || !whole_array)
 	{
 	  int dim;
 
-	  gfc_add_modify (&se.pre, desc, se.expr);
+	  if (whole_array)
+	    gfc_add_modify (&se.pre, desc, se.expr);
 
 	  /* The generated descriptor has lower bound zero (as array
 	     temporary), shift bounds so we get lower bounds of 1.  */
@@ -1606,7 +1619,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	      : e->symtree->n.sym->backend_decl;
 	  tmp = gfc_get_element_type (TREE_TYPE (tmp));
 	  tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
-	  gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
+	  gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
 	}
 
       /* Done, register stuff as init / cleanup code.  */
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 061222f..b106794 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "toplev.h"	/* For rest_of_decl_compilation.  */
 #include "trans-types.h"
 #include "trans-const.h"
+#include "trans-array.h"
 #include "dwarf2out.h"	/* For struct array_descr_info.  */
 #include "attribs.h"
 
@@ -1786,6 +1787,12 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
 				    gfc_array_index_type, &chain);
   TREE_NO_WARNING (decl) = 1;
 
+  /* Add the span component.  */
+  decl = gfc_add_field_to_struct_1 (fat_type,
+				    get_identifier ("span"),
+				    gfc_array_index_type, &chain);
+  TREE_NO_WARNING (decl) = 1;
+
   /* Build the array type for the stride and bound components.  */
   if (dimen + codimen > 0)
     {
@@ -2715,6 +2722,11 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
       if (!c->backend_decl)
 	c->backend_decl = field;
 
+      if (c->attr.pointer && c->attr.dimension
+	  && !(c->ts.type == BT_DERIVED
+	       && strcmp (c->name, "_data") == 0))
+	GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
+
       /* Do not add a caf_token field for classes' data components.  */
       if (codimen && !c->attr.dimension && !c->attr.codimension
 	  && (c->attr.allocatable || c->attr.pointer)
@@ -3154,7 +3166,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
 {
   int rank, dim;
   bool indirect = false;
-  tree etype, ptype, field, t, base_decl;
+  tree etype, ptype, t, base_decl;
   tree data_off, dim_off, dtype_off, dim_size, elem_size;
   tree lower_suboff, upper_suboff, stride_suboff;
 
@@ -3211,24 +3223,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
   if (indirect)
     base_decl = build1 (INDIRECT_REF, ptype, base_decl);
 
-  if (GFC_TYPE_ARRAY_SPAN (type))
-    elem_size = GFC_TYPE_ARRAY_SPAN (type);
-  else
-    elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
-  field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
-  data_off = byte_position (field);
-  field = DECL_CHAIN (field);
-  field = DECL_CHAIN (field);
-  dtype_off = byte_position (field);
-  field = DECL_CHAIN (field);
-  dim_off = byte_position (field);
-  dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
-  field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
-  stride_suboff = byte_position (field);
-  field = DECL_CHAIN (field);
-  lower_suboff = byte_position (field);
-  field = DECL_CHAIN (field);
-  upper_suboff = byte_position (field);
+  elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+
+  gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off,
+				       &dim_size, &stride_suboff,
+				       &lower_suboff, &upper_suboff);
 
   t = base_decl;
   if (!integer_zerop (data_off))
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index cb6a57f..149f482 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -305,6 +305,67 @@ gfc_build_addr_expr (tree type, tree t)
 }
 
 
+static tree
+get_array_span (tree type, tree decl)
+{
+  tree span;
+
+  /* Return the span for deferred character length array references.  */
+  if (type && TREE_CODE (type) == ARRAY_TYPE
+      && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
+      && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
+	  || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
+      && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
+	  || TREE_CODE (decl) == FUNCTION_DECL
+	  || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
+					== DECL_CONTEXT (decl)))
+    {
+      span = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+      span = fold_convert (gfc_array_index_type, span);
+    }
+  /* Likewise for class array or pointer array references.  */
+  else if (TREE_CODE (decl) == FIELD_DECL
+	   || VAR_OR_FUNCTION_DECL_P (decl)
+	   || TREE_CODE (decl) == PARM_DECL)
+    {
+      if (GFC_DECL_CLASS (decl))
+	{
+	  /* When a temporary is in place for the class array, then the
+	     original class' declaration is stored in the saved
+	     descriptor.  */
+	  if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+	    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+	  else
+	    {
+	      /* Allow for dummy arguments and other good things.  */
+	      if (POINTER_TYPE_P (TREE_TYPE (decl)))
+		decl = build_fold_indirect_ref_loc (input_location, decl);
+
+	      /* Check if '_data' is an array descriptor.  If it is not,
+		 the array must be one of the components of the class
+		 object, so return a null span.  */
+	      if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
+					  gfc_class_data_get (decl))))
+		return NULL_TREE;
+	    }
+	  span = gfc_class_vtab_size_get (decl);
+	}
+      else if (GFC_DECL_PTR_ARRAY_P (decl))
+	{
+	  if (TREE_CODE (decl) == PARM_DECL)
+	    decl = build_fold_indirect_ref_loc (input_location, decl);
+	  span = gfc_conv_descriptor_span_get (decl);
+	}
+      else
+	span = NULL_TREE;
+    }
+  else
+    span = NULL_TREE;
+
+  return span;
+}
+
+
 /* Build an ARRAY_REF with its natural type.  */
 
 tree
@@ -312,7 +373,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 {
   tree type = TREE_TYPE (base);
   tree tmp;
-  tree span;
+  tree span = NULL_TREE;
 
   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
     {
@@ -331,77 +392,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 
   type = TREE_TYPE (type);
 
-  /* Use pointer arithmetic for deferred character length array
-     references.  */
-  if (type && TREE_CODE (type) == ARRAY_TYPE
-      && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
-      && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
-	  || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
-      && decl
-      && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
-	  || TREE_CODE (decl) == FUNCTION_DECL
-	  || (DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
-	      == DECL_CONTEXT (decl))))
-    span = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-  else
-    span = NULL_TREE;
-
   if (DECL_P (base))
     TREE_ADDRESSABLE (base) = 1;
 
   /* Strip NON_LVALUE_EXPR nodes.  */
   STRIP_TYPE_NOPS (offset);
 
-  /* If the array reference is to a pointer, whose target contains a
-     subreference, use the span that is stored with the backend decl
-     and reference the element with pointer arithmetic.  */
-  if ((decl && (TREE_CODE (decl) == FIELD_DECL
-		|| VAR_OR_FUNCTION_DECL_P (decl)
-		|| TREE_CODE (decl) == PARM_DECL)
-       && ((GFC_DECL_SUBREF_ARRAY_P (decl)
-	    && !integer_zerop (GFC_DECL_SPAN (decl)))
-	   || GFC_DECL_CLASS (decl)
-	   || span != NULL_TREE))
-      || vptr != NULL_TREE)
-    {
-      if (decl)
-	{
-	  if (GFC_DECL_CLASS (decl))
-	    {
-	      /* When a temporary is in place for the class array, then the
-		 original class' declaration is stored in the saved
-		 descriptor.  */
-	      if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
-		decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
-	      else
-		{
-		  /* Allow for dummy arguments and other good things.  */
-		  if (POINTER_TYPE_P (TREE_TYPE (decl)))
-		    decl = build_fold_indirect_ref_loc (input_location, decl);
-
-		  /* Check if '_data' is an array descriptor.  If it is not,
-		     the array must be one of the components of the class
-		     object, so return a normal array reference.  */
-		  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
-						gfc_class_data_get (decl))))
-		    return build4_loc (input_location, ARRAY_REF, type, base,
-				       offset, NULL_TREE, NULL_TREE);
-		}
-
-	      span = gfc_class_vtab_size_get (decl);
-	    }
-	  else if (GFC_DECL_SUBREF_ARRAY_P (decl))
-	    span = GFC_DECL_SPAN (decl);
-	  else if (span)
-	    span = fold_convert (gfc_array_index_type, span);
-	  else
-	    gcc_unreachable ();
-	}
-      else if (vptr)
-	span = gfc_vptr_size_get (vptr);
-      else
-	gcc_unreachable ();
+  /* If decl or vptr are non-null, pointer arithmetic for the array reference
+     is likely. Generate the 'span' for the array reference.  */
+  if (vptr)
+    span = gfc_vptr_size_get (vptr);
+  else if (decl)
+    span = get_array_span (type, decl);
 
+  /* If a non-null span has been generated reference the element with
+     pointer arithmetic.  */
+  if (span != NULL_TREE)
+    {
       offset = fold_build2_loc (input_location, MULT_EXPR,
 				gfc_array_index_type,
 				offset, span);
@@ -412,8 +419,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 	tmp = build_fold_indirect_ref_loc (input_location, tmp);
       return tmp;
     }
+  /* Otherwise use a straightforward array reference.  */
   else
-    /* Otherwise use a straightforward array reference.  */
     return build4_loc (input_location, ARRAY_REF, type, base, offset,
 		       NULL_TREE, NULL_TREE);
 }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d02f347..c970ace 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -982,7 +982,7 @@ struct GTY(()) lang_decl {
 #define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
 #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
 #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
-#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
+#define GFC_DECL_PTR_ARRAY_P(node) DECL_LANG_FLAG_6(node)
 #define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
 #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fdd128c..10f56bd 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,31 @@
+2017-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34640
+	* gfortran.dg/associate_24.f90: New test.
+	* gfortran.dg/assumed_type_2.f90: Adjust some of the tree dump
+	checks.
+	* gfortran.dg/no_arg_check_2.f90: Likewise.
+	* gfortran.dg/pointer_array_1.f90: New test.
+	* gfortran.dg/pointer_array_2.f90: New test.
+	* gfortran.dg/pointer_array_7.f90: New test.
+	* gfortran.dg/pointer_array_8.f90: New test.
+	* gfortran.dg/pointer_array_component_1.f90: New test.
+	* gfortran.dg/pointer_array_component_2.f90: New test.
+	* gfortran.dg/goacc/kernels-alias-4.f95: Bump up both tree scan
+	counts by 1.
+
+	PR fortran/40737
+	* gfortran.dg/pointer_array_3.f90: New test.
+
+	PR fortran/57116
+	* gfortran.dg/pointer_array_4.f90: New test.
+
+	PR fortran/55763
+	* gfortran.dg/pointer_array_5.f90: New test.
+
+	PR fortran/57019
+	* gfortran.dg/pointer_array_6.f90: New test.
+
 2017-09-09  Jonathan Wakely  <jwakely@redhat.com>
 
 	PR c++/81852
diff --git a/gcc/testsuite/gfortran.dg/associate_24.f90 b/gcc/testsuite/gfortran.dg/associate_24.f90
new file mode 100644
index 0000000..94ba378
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_24.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! From posting by Spectrum to clf on thread entitled "Bounds for array pointer dummy argument".
+!
+PROGRAM X
+    implicit none
+    TYPE T
+        INTEGER :: I
+    END TYPE T
+    TYPE(T), TARGET :: T1( 0:3 )
+
+    associate( P => T1 % I )
+        call check (lbound (P, 1), ubound (P, 1) ,1 , 4)
+    endassociate
+
+    associate( P2 => T1(:) % I )
+        call check (lbound (P2, 1), ubound (P2, 1) ,1 , 4)
+    endassociate
+
+    associate( Q => T1 )
+        call check (lbound (Q, 1), ubound (Q, 1) ,0 , 3)
+    endassociate
+
+    associate( Q2 => T1(:) )
+        call check (lbound (Q2, 1), ubound (Q2, 1) ,1 , 4)
+    endassociate
+contains
+    subroutine check (lbnd, ubnd, lower, upper)
+      integer :: lbnd, ubnd, lower, upper
+      if (lbnd .ne. lower) call abort
+      if (ubnd .ne. upper) call abort
+    end subroutine
+END PROGRAM X
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_2.f90 b/gcc/testsuite/gfortran.dg/assumed_type_2.f90
index f1a2074..a0e1bc1 100644
--- a/gcc/testsuite/gfortran.dg/assumed_type_2.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_type_2.f90
@@ -151,9 +151,9 @@ end
 ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
 
 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
-! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
-! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
 
diff --git a/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 b/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
index 36f7f65..415eb96 100644
--- a/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
+++ b/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
@@ -16,5 +16,5 @@ program main
 end program main
 
 ! Only the omp_data_i related loads should be annotated with cliques.
-! { dg-final { scan-tree-dump-times "clique 1 base 1" 3 "ealias" } }
-! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 4 "ealias" } }
+! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } }
+! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } }
diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90
index b3fb468..90e4c8c 100644
--- a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90
+++ b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90
@@ -133,9 +133,9 @@ end
 ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
 
 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
-! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
-! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
 
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_1.f90 b/gcc/testsuite/gfortran.dg/pointer_array_1.f90
new file mode 100644
index 0000000..b43101f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_1.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+!
+! Check the fix for PR34640 comments 1 and 3.
+!
+! This involves passing and returning pointer array components that
+! point to components of arrays of derived types.
+!
+MODULE test
+  IMPLICIT NONE
+  TYPE :: my_type
+    INTEGER :: value
+    integer :: tag
+  END TYPE
+CONTAINS
+  SUBROUTINE get_values(values, switch)
+    INTEGER, POINTER :: values(:)
+    integer :: switch
+    TYPE(my_type), POINTER :: d(:)
+    allocate (d, source = [my_type(1,101), my_type(2,102)])
+    if (switch .eq. 1) then
+      values => d(:)%value
+      if (any (values .ne. [1,2])) print *, values(2)
+    else
+      values => d(:)%tag
+      if (any (values .ne. [101,102])) call abort
+    end if
+  END SUBROUTINE
+
+  function return_values(switch) result (values)
+    INTEGER, POINTER :: values(:)
+    integer :: switch
+    TYPE(my_type), POINTER :: d(:)
+    allocate (d, source = [my_type(1,101), my_type(2,102)])
+    if (switch .eq. 1) then
+      values => d(:)%value
+      if (any (values .ne. [1,2])) call abort
+    else
+      values => d(:)%tag
+      if (any (values([2,1]) .ne. [102,101])) call abort
+    end if
+  END function
+END MODULE
+
+  use test
+  integer, pointer :: x(:)
+  type :: your_type
+    integer, pointer :: x(:)
+  end type
+  type(your_type) :: y
+
+  call get_values (x, 1)
+  if (any (x .ne. [1,2])) call abort
+  call get_values (y%x, 2)
+  if (any (y%x .ne. [101,102])) call abort
+
+  x => return_values (2)
+  if (any (x .ne. [101,102])) call abort
+  y%x => return_values (1)
+  if (any (y%x .ne. [1,2])) call abort
+end
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_2.f90 b/gcc/testsuite/gfortran.dg/pointer_array_2.f90
new file mode 100644
index 0000000..1f9c137
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_2.f90
@@ -0,0 +1,143 @@
+! { dg-do compile }
+!
+! Test the fix for PR40737 as part of the overall fix for PR34640.
+!
+! Contributed by David Hough  <dh458@oakapple.net>
+!
+module testmod
+
+integer, parameter :: standard_integer = 1
+integer, parameter :: int = KIND( standard_integer)
+
+integer, parameter :: i8  = selected_int_kind(12)
+integer, parameter :: i4  = selected_int_kind(8)
+integer, parameter :: i2  = selected_int_kind(4)
+
+integer, parameter :: standard_real = 1.
+integer, parameter :: std_real = KIND( standard_real)
+
+integer, parameter :: r8  = selected_real_kind(12)
+integer, parameter :: r4  = selected_real_kind(6)
+integer, parameter :: double  = selected_real_kind(20)
+
+integer, parameter :: name_string_length = 40
+integer, parameter :: file_name_length = 60
+integer, parameter :: text_string_length = 80
+integer, parameter :: max_kwd_lgth = file_name_length
+
+integer(int) :: bytes_per_int  = 4
+integer(int) :: bytes_per_real = 8
+integer(int) :: workcomm, spincomm
+
+   integer(int), parameter :: nb_directions = 3,  &
+                              direction_x = 1,    &
+                              direction_y = 2,    &
+                              direction_z = 3,    &
+                              nb_ghost_cells = 5     ! might be different for the lagrange step?
+
+   integer(int), parameter :: ends = 4,            &
+                              lower_ghost = 1,     &
+                              lower_interior = 2,  &
+                              upper_interior = 3,  &
+                              upper_ghost = 4
+
+   ! Neighbors
+   integer(int), parameter :: side = 2,       &
+                              lower_end = 1,  &
+                              upper_end = 2
+
+
+   integer(int), parameter :: nb_variables = 5,    &
+                              ro_var = 1,          &
+                              ets_var = 2,         &
+                              u_var = 3,           &
+                              up1_var = 4,         &
+                              up2_var = 5,         &
+                              eis_var = 6,         &
+                              ecs_var = 7,         &
+                              p_var = 8,           &
+                              c_var = 9,           &
+                              nb_var_sortie = 9
+
+   type :: VARIABLES_LIGNE
+      sequence
+      real, pointer, dimension( :, :) :: l
+   end type VARIABLES_LIGNE
+
+   type VARIABLES_MAILLE
+      sequence
+      real(r8), dimension( nb_variables) :: cell_var
+   end type VARIABLES_MAILLE
+
+   integer(int), dimension( nb_directions) :: &
+         first_real_cell,    &  ! without ghost cells
+         last_real_cell,     &  !
+         nb_real_cells,      &  !
+         first_work_cell,    &  ! including ghost cells
+         last_work_cell,     &  !
+         nb_work_cells,      &  !
+         global_nb_cells        ! number of real cells, for the entire grid
+
+   integer(int) :: dim_probleme  ! dimension du probleme (1, 2 ou 3)
+
+   integer(int) :: largest_local_size   ! the largest of the 3 dimensions of the local grid
+
+   ! Hydro variables of the actual domain
+   ! There are 3 copies of these, for use according to current work direction
+   type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) ::  &
+            Hydro_vars_XYZ,  &
+            Hydro_vars_YZX,  &
+            Hydro_vars_ZXY
+
+   ! Pointers to current and next Hydro var arrays
+   type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars,      &
+                                                            Hydro_vars_next
+
+   ! Which of these 3 copies of the 3D arrays has been updated last
+   integer(int) :: last_updated_3D_array = 0
+
+   real(r8), pointer, dimension( :) ::        &
+         ! Variables "permanentes" (entrant dans la projection)
+         Ro,      & ! densite
+         Ets,     & ! energie totale specifique
+         Um,      & ! vitesse aux mailles, dans la direction de travail
+         Xn,      & ! abscisse en fin de pas de temps
+         ! Variables en lecture seulement
+         Um_p1,   & ! vitesse aux mailles, dans les directions
+         Um_p2,   & !                      orthogonales
+         Xa,      & ! abscisses des noeuds en debut de pas de temps
+         Dxa,     & ! longueur des mailles en debut de pas de temps
+         U_dxa      ! inverses des longueurs des mailles
+
+end module testmod
+
+
+subroutine TF_AD_SPLITTING_DRIVER_PLANE
+
+use testmod
+
+implicit none
+save
+
+   real(r8), allocatable, dimension( :) ::  &
+         ! Variables maille recalculees a chaque pas de temps
+         Eis,     & ! energie interne specifique (seulement pour calculer la pression)
+         Vit_son, & ! comme son nom l'indique
+         C_f_l,   & ! nombre de Courant
+         Pm,      & ! pression aux mailles
+         ! Variables aux noeuds
+         Un,      & ! vitesse des noeuds
+         Pn         ! pression aux noeuds
+
+
+integer(int) :: i, j, k
+integer(int) :: first_cell, last_cell
+
+         Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var)
+         Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var)
+         Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var)
+         Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var)
+         Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var)
+
+end subroutine TF_AD_SPLITTING_DRIVER_PLANE
+
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_3.f90 b/gcc/testsuite/gfortran.dg/pointer_array_3.f90
new file mode 100644
index 0000000..d760167
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_3.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! Test the fix for PR40737 comment 17 as part of the overall fix for PR34640.
+!
+! Contributed by Josh Hykes  <joshuahykes@yahoo.com>
+!
+   module test_mod
+!
+   type t1
+      character(8)  :: string
+   end type t1
+!
+   type t2
+     integer :: tab
+     type(t1), pointer :: fp(:)
+   end type t2
+!
+   type t3
+      integer :: tab
+      type(t2), pointer :: as
+   end type t3
+!
+   type(t3), pointer :: as_typ(:) => null()
+!
+   character(8),  pointer, public :: p(:)
+!
+   contains
+!
+   subroutine as_set_alias (i)
+!
+   implicit none
+!
+   integer, intent(in)    :: i
+!
+     allocate (as_typ(2))
+     allocate (as_typ(1)%as)
+     allocate (as_typ(1)%as%fp(2), source = [t1("abcdefgh"),t1("ijklmnop")])
+     p => as_typ(i)%as%fp(:)%string
+!
+   end subroutine as_set_alias
+!
+   end module test_mod
+
+   program test_prog
+   use test_mod
+   call as_set_alias(1)
+   if (any (p .ne. ["abcdefgh","ijklmnop"])) call abort
+   deallocate (as_typ(1)%as%fp)
+   deallocate (as_typ(1)%as)
+   deallocate (as_typ)
+   end program test_prog
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_4.f90 b/gcc/testsuite/gfortran.dg/pointer_array_4.f90
new file mode 100644
index 0000000..31a90a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_4.f90
@@ -0,0 +1,75 @@
+! { dg-do run }
+!
+! Test the fix for PR57116 as part of the overall fix for PR34640.
+!
+! Contributed by Reinhold Bader  <Bader@lrz.de>
+!
+module mod_rtti_ptr
+  implicit none
+  type :: foo
+     real :: v
+     integer :: i
+  end type foo
+contains
+  subroutine extract(this, v, ic)
+    class(*), target :: this(:)
+    real, pointer :: v(:)
+    integer :: ic
+    select type (this)
+    type is (real)
+       v => this(ic:)
+    class is (foo)
+       v => this(ic:)%v
+    end select
+  end subroutine extract
+end module
+
+program prog_rtti_ptr
+  use mod_rtti_ptr
+  class(*), allocatable, target :: o(:)
+  real, pointer :: v(:)
+
+  allocate(o(3), source=[1.0, 2.0, 3.0])
+  call extract(o, v, 2)
+  if (size(v) == 2 .and. all (v == [2.0, 3.0])) then
+     deallocate(o)
+  else
+     call abort
+  end if
+
+  allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)])
+  call extract(o, v, 2)
+  if (size(v) == 2 .and. all (v == [4.0, 5.0])) then
+     deallocate(o)
+  else
+     call abort
+  end if
+
+! The rest tests the case in comment 2 <janus@gcc.gnu.org>
+
+  call extract1 (v, 1)
+  if (any (v /= [1.0, 2.0])) call abort
+  call extract1 (v, 2)  ! Call to deallocate pointer.
+
+contains
+  subroutine extract1(v, flag)
+    type :: foo
+       real :: v
+       character(4) :: str
+    end type
+    class(foo), pointer, save :: this(:)
+    real, pointer :: v(:)
+    integer :: flag
+
+    if (flag == 1) then
+      allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")])
+      select type (this)
+        class is (foo)
+          v => this(1:2)%v
+      end select
+    else
+      deallocate (this)
+    end if
+  end subroutine
+
+end program prog_rtti_ptr
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_5.f90 b/gcc/testsuite/gfortran.dg/pointer_array_5.f90
new file mode 100644
index 0000000..312d097
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_5.f90
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+  program change_field_type
+    use, intrinsic :: iso_c_binding
+    implicit none
+    REAL(kind=c_float), POINTER :: vector_comp(:)
+    TYPE, BIND(C) :: scalar_vector
+       REAL(kind=c_float) :: scalar
+       REAL(kind=c_float) :: vec(3)
+    END TYPE
+    TYPE, BIND(C) :: scalar_vector_matrix
+       REAL(kind=c_float) :: scalar
+       REAL(kind=c_float) :: vec(3)
+       REAL(kind=c_float) :: mat(3,3)
+    END TYPE
+    CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:)
+    real, pointer :: v1(:)
+
+    allocate(one_d_field(3), &
+             source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), &
+                         scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), &
+                         scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) )  /) )
+
+    call extract_vec(one_d_field, 1, 2)
+    if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) call abort
+    deallocate(one_d_field)   ! v1 becomes undefined
+
+    allocate(one_d_field(1), &
+         source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), &
+         reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), &
+                 (/3, 3/) ) ) /) )
+
+    call extract_vec(one_d_field, 2, 1)
+    if (abs (vector_comp(1) + 1.0) > 1e-4) call abort
+    call extract_vec(one_d_field, 2, 3)
+    if (abs (vector_comp(1) - 1.0) > 1e-4) call abort
+    deallocate(one_d_field)   ! v1 becomes undefined
+  contains
+    subroutine extract_vec(field, tag, ic)
+        use, intrinsic :: iso_c_binding
+        CLASS(*), TARGET :: field(:)
+        INTEGER(kind=c_int), value :: tag, ic
+
+        type(scalar_vector), pointer :: sv(:)
+        type(scalar_vector_matrix), pointer :: svm(:)
+
+        select type (field)
+        type is (real(c_float))
+          vector_comp => field
+        class default
+          select case (tag)
+          case (1)
+             sv => field
+             vector_comp => sv(:)%vec(ic)
+          case (2)
+             svm => field
+             vector_comp => svm(:)%vec(ic)
+          end select
+        end select
+    end subroutine
+  end program
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_6.f90 b/gcc/testsuite/gfortran.dg/pointer_array_6.f90
new file mode 100644
index 0000000..8668556
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_6.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Test the fix for PR57019 comment 4 as part of the overall fix for PR34640.
+!
+! Contributed by  <thambsup@gmail.com>
+!
+  type cParticle
+    real(4) :: v(3)
+  endtype cParticle
+
+  type pCItem
+    type(cParticle) :: Ele
+  end type pCItem
+
+  type(pCItem), target, dimension(1:1,1:1) :: pCellArray
+  type(cParticle), pointer, dimension(:,:) :: pArray
+  real(4), pointer, dimension(:) :: v_pointer
+  real(4), dimension(3) :: v_real = 99.
+
+  pArray => pCellArray%Ele
+  v_pointer => pArray(1,1)%v;
+  v_pointer = v_real !OK %%%%%%%%%%%%
+  if (any (int (pArray(1,1)%v) .ne. 99)) call abort
+
+  v_real = 88
+  pArray(1,1)%v = v_real !SEGFAULT %%%%%%%%%%%%%%%%%%%%%%%%
+  if (any (int (v_pointer) .ne. 88)) call abort
+end
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_7.f90 b/gcc/testsuite/gfortran.dg/pointer_array_7.f90
new file mode 100644
index 0000000..1aa48b7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_7.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+!
+! Test for the fix for PR34640. In this case, final testing of the
+! patch revealed that in some cases the actual descriptor was not
+! being passed to procedure dummy pointers.
+!
+! Contributed by Thomas Koenig  <tkoenig@netcologne.de>
+!
+module x
+  use iso_c_binding
+  implicit none
+  type foo
+     complex :: c
+     integer :: i
+  end type foo
+contains
+  subroutine printit(c, a)
+    complex, pointer, dimension(:) :: c
+    integer :: i
+    integer(kind=c_intptr_t) :: a
+    a = transfer(c_loc(c(2)),a)
+  end subroutine printit
+end module x
+
+program main
+  use x
+  use iso_c_binding
+  implicit none
+  type(foo), dimension(5), target :: a
+  integer :: i
+  complex, dimension(:), pointer :: pc
+  integer(kind=c_intptr_t) :: s1, s2, s3
+  a%i = 0
+  do i=1,5
+     a(i)%c = cmplx(i**2,i)
+  end do
+  pc => a%c
+  call printit(pc, s3)
+
+  s1 = transfer(c_loc(a(2)%c),s1)
+  if (s1 /= s3) call abort
+
+  s2 = transfer(c_loc(pc(2)),s2)
+  if (s2 /= s3) call abort
+
+end program main
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_8.f90 b/gcc/testsuite/gfortran.dg/pointer_array_8.f90
new file mode 100644
index 0000000..bbf2c99
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_8.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+!
+! Make sure that the fix for pr34640 works with class pointers.
+!
+  type :: mytype
+    real :: r
+    integer :: i
+  end type
+
+  type :: thytype
+    real :: r
+    integer :: i
+    type(mytype) :: der
+  end type
+
+  type(thytype), dimension(0:2), target :: tgt
+  class(*), dimension(:), pointer :: cptr
+  class(mytype), dimension(:), pointer :: cptr1
+  integer :: i
+  integer(8) :: s1, s2
+
+  tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)]
+
+  cptr => tgt%i
+  if (lbound (cptr, 1) .ne. 1)  Call abort     ! Not a whole array target!
+
+  s1 = loc(cptr)
+  call foo (cptr, s2)                          ! Check bounds not changed...
+  if (s1 .ne. s2) Call abort                   ! ...and that the descriptor is passed.
+
+  select type (cptr)
+    type is (integer)
+      if (any (cptr .ne. [1,2,3])) call abort  ! Check the the scalarizer works.
+      if (cptr(2) .ne. 2) call abort           ! Check ordinary array indexing.
+  end select
+
+  cptr(1:3) => tgt%der%r                       ! Something a tad more complicated!
+
+  select type (cptr)
+    type is (real)
+      if (any (int(cptr) .ne. [2,4,6])) call abort
+      if (any (int(cptr([2,3,1])) .ne. [4,6,2])) call abort
+      if (int(cptr(3)) .ne. 6) call abort
+  end select
+
+  cptr1(1:3) => tgt%der
+
+  s1 = loc(cptr1)
+  call bar(cptr1, s2)
+  if (s1 .ne. s2) Call abort                   ! Check that the descriptor is passed.
+
+  select type (cptr1)
+    type is (mytype)
+      if (any (cptr1%i .ne. [2,4,6])) call abort
+      if (cptr1(2)%i .ne. 4) call abort
+  end select
+
+contains
+
+  subroutine foo (arg, addr)
+    class(*), dimension(:), pointer :: arg
+    integer(8) :: addr
+    addr = loc(arg)
+    select type (arg)
+      type is (integer)
+        if (any (arg .ne. [1,2,3])) call abort  ! Check the the scalarizer works.
+        if (arg(2) .ne. 2) call abort           ! Check ordinary array indexing.
+    end select
+  end subroutine
+
+  subroutine bar (arg, addr)
+    class(mytype), dimension(:), pointer :: arg
+    integer(8) :: addr
+    addr = loc(arg)
+    select type (arg)
+      type is (mytype)
+        if (any (arg%i .ne. [2,4,6])) call abort
+        if (arg(2)%i .ne. 4) call abort
+    end select
+  end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 b/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90
new file mode 100644
index 0000000..b96071b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Check the fix for PR34640 comment 28.
+!
+! This involves pointer array components that point to components of arrays
+! of derived types.
+!
+  type var_tables
+     real, pointer :: rvar(:)
+  end type
+
+  type real_vars
+     real r
+     real :: index
+  end type
+
+  type(var_tables) ::  vtab_r
+  type(real_vars),  target :: x(2)
+  real, pointer :: z(:)
+  real :: y(2)
+
+  x = [real_vars (11.0, 1.0), real_vars (42.0, 2.0)]
+  vtab_r%rvar => x%r
+  if (any (abs (vtab_r%rvar - [11.0, 42.0]) > 1.0e-5)) call abort  ! Check skipping 'index; is OK.
+
+  y = vtab_r%rvar
+  if (any (abs (y - [11.0, 42.0]) > 1.0e-5)) call abort  ! Check that the component is usable in assignment.
+
+  call foobar (vtab_r, [11.0, 42.0])
+
+  vtab_r = barfoo ()
+
+  call foobar (vtab_r, [111.0, 142.0])
+
+contains
+  subroutine foobar (vtab, array)
+    type(var_tables) ::  vtab
+    real :: array (:)
+    if (any (abs (vtab%rvar - array) > 1.0e-5)) call abort  ! Check passing as a dummy.
+    if (abs (vtab%rvar(2) - array(2)) > 1.0e-5) call abort  ! Check component reference.
+  end subroutine
+
+  function barfoo () result(res)
+    type(var_tables) ::  res
+    allocate (res%rvar(2), source = [111.0, 142.0])  ! Check allocation
+  end function
+end
diff --git a/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 b/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90
new file mode 100644
index 0000000..bde66f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90
@@ -0,0 +1,43 @@
+! { dg-do run }
+!
+! Test the fix for PR34640. In the first version of the fix, the first
+! testcase in PR51218 failed with a segfault. This test extracts the
+! failing part and checks that all is well.
+!
+  type t_info_block
+    integer                      :: n     =  0      ! number of elements
+  end type t_info_block
+  !
+  type t_dec_info
+    integer                      :: n     =  0      ! number of elements
+    integer                      :: n_b   =  0      ! number of blocks
+    type (t_info_block) ,pointer :: b (:) => NULL() ! info blocks
+  end type t_dec_info
+  !
+  type t_vector_segm
+    integer           :: n    =  0      ! number of elements
+    real ,pointer :: x(:) => NULL() ! coefficients
+  end type t_vector_segm
+  !
+  type t_vector
+    type (t_dec_info)    ,pointer :: info    => NULL()  ! decomposition info
+    integer                       :: n       =  0       ! number of elements
+    integer                       :: n_s     =  0       ! number of segments
+    integer                       :: alloc_l =  0       ! allocation level
+    type (t_vector_segm) ,pointer :: s (:)   => NULL()  ! vector blocks
+  end type t_vector
+
+
+  type(t_vector) :: z
+  type(t_vector_segm), pointer :: ss
+
+  allocate (z%s(2))
+  do i = 1, 2
+    ss => z%s(i)
+    allocate (ss%x(2), source = [1.0, 2.0]*real(i))
+  end do
+
+! These lines would segfault.
+  if (int (sum (z%s(1)%x)) .ne. 3) call abort
+  if (int (sum (z%s(1)%x * z%s(2)%x)) .ne. 10) call abort
+end
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index ba57e61..3dd2718 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2017-09-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34640
+	* libgfortran/libgfortran.h: Add span field to descriptor.
+	* libgfortran/libtool-version : Bump up version number to 5:0:0.
+
 2017-08-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/78387
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 22f4123..cdbdd951 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -339,6 +339,7 @@ struct {\
   type *base_addr;\
   size_t offset;\
   index_type dtype;\
+  index_type span;\
   descriptor_dimension dim[r];\
 }
 
diff --git a/libgfortran/libtool-version b/libgfortran/libtool-version
index 7121990..4ce57a9 100644
--- a/libgfortran/libtool-version
+++ b/libgfortran/libtool-version
@@ -3,4 +3,4 @@
 # This is a separate file so that version updates don't involve re-running
 # automake.
 # CURRENT:REVISION:AGE
-4:0:0
+5:0:0