re PR fortran/29396 (segfault with character pointer association)

2007-09-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29396
	PR fortran/29606
	PR fortran/30625
	PR fortran/30871
	* trans.h : Add extra argument to gfc_build_array_ref. Rename
	gfc_conv_aliased_arg to gfc_conv_subref_array_arg.  Move
	prototype of is_aliased_array to gfortran.h and rename it
	gfc_is_subref_array.  Add field span to lang_decl, add a new
	decl lang specific flag accessed by GFC_DECL_SUBREF_ARRAY_P
	and a new type flag GFC_DECL_SUBREF_ARRAY_P.
	* trans.c (gfc_build_array_ref): Add the new argument, decl.
	If this is a subreference array pointer, use the lang_decl
	field 'span' to calculate the offset in bytes and use pointer
	arithmetic to address the element.
	* trans-array.c (gfc_conv_scalarized_array_ref,
	gfc_conv_array_ref): Add the backend declaration as the third
	field, if it is likely to be a subreference array pointer.
	(gfc_conv_descriptor_dimension, gfc_trans_array_ctor_element,
	gfc_trans_array_constructor_element, structure_alloc_comps,
	gfc_conv_array_index_offset): For all other references to
	gfc_build_array_ref, set the third argument to NULL.
	(gfc_get_dataptr_offset): New function.
	(gfc_conv_expr_descriptor): If the rhs of a pointer assignment
	is a subreference array, then calculate the offset to the
	subreference of the first element and set the descriptor data
	pointer to this, using gfc_get_dataptr_offset.
	trans-expr.c (gfc_get_expr_charlen): Use the expression for the
	character length for a character subreference.
	(gfc_conv_substring, gfc_conv_subref_array_arg): Add NULL for
	third argument in call to gfc_build_array_ref.
	(gfc_conv_aliased_arg): Rename to gfc_conv_subref_array_arg.
	(is_aliased_array): Remove.
	(gfc_conv_function_call): Change reference to is_aliased_array
	to gfc_is_subref_array and reference to gfc_conv_aliased_arg to
	gfc_conv_subref_array_arg.
	(gfc_trans_pointer_assignment): Add the array element length to
	the lang_decl 'span' field.
	* gfortran.h : Add subref_array_pointer to symbol_attribute and
	add the prototype for gfc_is_subref_array.
	* trans-stmt.c : Add NULL for third argument in all references
	to gfc_build_array_ref.
	* expr.c (gfc_is_subref_array): Renamed is_aliased_array.
	If this is a subreference array pointer, return true.
	(gfc_check_pointer_assign): If the rhs is a subreference array,
	set the lhs subreference_array_pointer attribute.
	* trans-decl.c (gfc_get_symbol_decl): Allocate the lang_decl
	field if the symbol is a subreference array pointer and set an
	initial value of zero for the 'span' field.
	* trans-io.c (set_internal_unit): Refer to is_subref_array and
	gfc_conv_subref_array_arg.
	(nml_get_addr_expr): Add NULL third argument to
	gfc_build_array_ref. 
	(gfc_trans_transfer): Use the scalarizer for a subreference
	array.

2007-09-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29396
	PR fortran/29606
	PR fortran/30625
	PR fortran/30871
	* gfortran.dg/subref_array_pointer_1.f90: New test.
	* gfortran.dg/subref_array_pointer_2.f90: New test.

From-SVN: r128523

13 files changed, 502 insertions, 77 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8760abe..6aca2c7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,60 @@
+2007-09-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29396
+	PR fortran/29606
+	PR fortran/30625
+	PR fortran/30871
+	* trans.h : Add extra argument to gfc_build_array_ref. Rename
+	gfc_conv_aliased_arg to gfc_conv_subref_array_arg.  Move
+	prototype of is_aliased_array to gfortran.h and rename it
+	gfc_is_subref_array.  Add field span to lang_decl, add a new
+	decl lang specific flag accessed by GFC_DECL_SUBREF_ARRAY_P
+	and a new type flag GFC_DECL_SUBREF_ARRAY_P.
+	* trans.c (gfc_build_array_ref): Add the new argument, decl.
+	If this is a subreference array pointer, use the lang_decl
+	field 'span' to calculate the offset in bytes and use pointer
+	arithmetic to address the element.
+	* trans-array.c (gfc_conv_scalarized_array_ref,
+	gfc_conv_array_ref): Add the backend declaration as the third
+	field, if it is likely to be a subreference array pointer.
+	(gfc_conv_descriptor_dimension, gfc_trans_array_ctor_element,
+	gfc_trans_array_constructor_element, structure_alloc_comps,
+	gfc_conv_array_index_offset): For all other references to
+	gfc_build_array_ref, set the third argument to NULL.
+	(gfc_get_dataptr_offset): New function.
+	(gfc_conv_expr_descriptor): If the rhs of a pointer assignment
+	is a subreference array, then calculate the offset to the
+	subreference of the first element and set the descriptor data
+	pointer to this, using gfc_get_dataptr_offset.
+	trans-expr.c (gfc_get_expr_charlen): Use the expression for the
+	character length for a character subreference.
+	(gfc_conv_substring, gfc_conv_subref_array_arg): Add NULL for
+	third argument in call to gfc_build_array_ref.
+	(gfc_conv_aliased_arg): Rename to gfc_conv_subref_array_arg.
+	(is_aliased_array): Remove.
+	(gfc_conv_function_call): Change reference to is_aliased_array
+	to gfc_is_subref_array and reference to gfc_conv_aliased_arg to
+	gfc_conv_subref_array_arg.
+	(gfc_trans_pointer_assignment): Add the array element length to
+	the lang_decl 'span' field.
+	* gfortran.h : Add subref_array_pointer to symbol_attribute and
+	add the prototype for gfc_is_subref_array.
+	* trans-stmt.c : Add NULL for third argument in all references
+	to gfc_build_array_ref.
+	* expr.c (gfc_is_subref_array): Renamed is_aliased_array.
+	If this is a subreference array pointer, return true.
+	(gfc_check_pointer_assign): If the rhs is a subreference array,
+	set the lhs subreference_array_pointer attribute.
+	* trans-decl.c (gfc_get_symbol_decl): Allocate the lang_decl
+	field if the symbol is a subreference array pointer and set an
+	initial value of zero for the 'span' field.
+	* trans-io.c (set_internal_unit): Refer to is_subref_array and
+	gfc_conv_subref_array_arg.
+	(nml_get_addr_expr): Add NULL third argument to
+	gfc_build_array_ref. 
+	(gfc_trans_transfer): Use the scalarizer for a subreference
+	array.
+
 2007-09-13  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* iresolve.c (resolve_mask_arg): If a mask is an array
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 6ffcf7e..815612e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -792,6 +792,35 @@ gfc_is_constant_expr (gfc_expr *e)
 }
 
 
+/* Is true if an array reference is followed by a component or substring
+   reference.  */
+bool
+is_subref_array (gfc_expr * e)
+{
+  gfc_ref * ref;
+  bool seen_array;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (e->symtree->n.sym->attr.subref_array_pointer)
+    return true;
+
+  seen_array = false;
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY
+	    && ref->u.ar.type != AR_ELEMENT)
+	seen_array = true;
+
+      if (seen_array
+	    && ref->type != REF_ARRAY)
+	return seen_array;
+    }
+  return false;
+}
+
+
 /* Try to collapse intrinsic expressions.  */
 
 static try
@@ -2802,6 +2831,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
+  if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+    lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
   attr = gfc_expr_attr (rvalue);
   if (!attr.target && !attr.pointer)
     {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b2da38f..a5f4881 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -578,7 +578,7 @@ typedef struct
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
-    implied_index:1;
+    implied_index:1, subref_array_pointer:1;
 
   ENUM_BITFIELD (save_state) save:2;
 
@@ -2172,6 +2172,7 @@ void gfc_free_actual_arglist (gfc_actual_arglist *);
 gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+bool is_subref_array (gfc_expr *);
 
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 69be8ef..1e02b81 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -245,7 +245,7 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
 	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
 
   tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
-  tmp = gfc_build_array_ref (tmp, dim);
+  tmp = gfc_build_array_ref (tmp, dim, NULL);
   return tmp;
 }
 
@@ -961,7 +961,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
 
   /* Store the value.  */
   tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
-  tmp = gfc_build_array_ref (tmp, offset);
+  tmp = gfc_build_array_ref (tmp, offset, NULL);
   if (expr->ts.type == BT_CHARACTER)
     {
       gfc_conv_string_parameter (se);
@@ -1181,7 +1181,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 	      /* Use BUILTIN_MEMCPY to assign the values.  */
 	      tmp = gfc_conv_descriptor_data_get (desc);
 	      tmp = build_fold_indirect_ref (tmp);
-	      tmp = gfc_build_array_ref (tmp, *poffset);
+	      tmp = gfc_build_array_ref (tmp, *poffset, NULL);
 	      tmp = build_fold_addr_expr (tmp);
 	      init = build_fold_addr_expr (init);
 
@@ -2167,7 +2167,7 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
 
 	  /* Read the vector to get an index into info->descriptor.  */
 	  data = build_fold_indirect_ref (gfc_conv_array_data (desc));
-	  index = gfc_build_array_ref (data, index);
+	  index = gfc_build_array_ref (data, index, NULL);
 	  index = gfc_evaluate_now (index, &se->pre);
 
 	  /* Do any bounds checking on the final info->descriptor index.  */
@@ -2219,6 +2219,7 @@ static void
 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
 {
   gfc_ss_info *info;
+  tree decl = NULL_TREE;
   tree index;
   tree tmp;
   int n;
@@ -2236,8 +2237,11 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
   if (!integer_zerop (info->offset))
     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
 
+  if (se->ss->expr && is_subref_array (se->ss->expr))
+    decl = se->ss->expr->symtree->n.sym->backend_decl;
+
   tmp = build_fold_indirect_ref (info->data);
-  se->expr = gfc_build_array_ref (tmp, index);
+  se->expr = gfc_build_array_ref (tmp, index, decl);
 }
 
 
@@ -2338,11 +2342,11 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
   tmp = gfc_conv_array_offset (se->expr);
   if (!integer_zerop (tmp))
     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
-      
+
   /* Access the calculated element.  */
   tmp = gfc_conv_array_data (se->expr);
   tmp = build_fold_indirect_ref (tmp);
-  se->expr = gfc_build_array_ref (tmp, index);
+  se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
 }
 
 
@@ -4336,6 +4340,116 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 }
 
 
+/* Calculate the overall offset, including subreferences.  */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+			bool subref, gfc_expr *expr)
+{
+  tree tmp;
+  tree field;
+  tree stride;
+  tree index;
+  gfc_ref *ref;
+  gfc_se start;
+  int n;
+
+  /* If offset is NULL and this is not a subreferenced array, there is
+     nothing to do.  */
+  if (offset == NULL_TREE)
+    {
+      if (subref)
+	offset = gfc_index_zero_node;
+      else
+	return;
+    }
+
+  tmp = gfc_conv_array_data (desc);
+  tmp = build_fold_indirect_ref (tmp);
+  tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+  /* Offset the data pointer for pointer assignments from arrays with
+     subreferences; eg. my_integer => my_type(:)%integer_component.  */
+  if (subref)
+    {
+      /* Go past the array reference.  */
+      for (ref = expr->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY &&
+	      ref->u.ar.type != AR_ELEMENT)
+	  {
+	    ref = ref->next;
+	    break;
+	  }
+
+      /* Calculate the offset for each subsequent subreference.  */
+      for (; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      field = ref->u.c.component->backend_decl;
+	      gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+	      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+	      break;
+
+	    case REF_SUBSTRING:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+	      gfc_init_se (&start, NULL);
+	      gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+	      gfc_add_block_to_block (block, &start.pre);
+	      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+	      break;
+
+	    case REF_ARRAY:
+	      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+			    && ref->u.ar.type == AR_ELEMENT);
+
+	      /* TODO - Add bounds checking.  */
+	      stride = gfc_index_one_node;
+	      index = gfc_index_zero_node;
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  tree itmp;
+		  tree jtmp;
+
+		  /* Update the index.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+		  itmp = gfc_evaluate_now (start.expr, block);
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+		  jtmp = gfc_evaluate_now (start.expr, block);
+		  itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
+		  itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
+		  index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+		  index = gfc_evaluate_now (index, block);
+
+		  /* Update the stride.  */
+		  gfc_init_se (&start, NULL);
+		  gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+		  itmp =  fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
+		  itmp =  fold_build2 (PLUS_EXPR, gfc_array_index_type,
+				       gfc_index_one_node, itmp);
+		  stride =  fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+		  stride = gfc_evaluate_now (stride, block);
+		}
+
+	      /* Apply the index to obtain the array element.  */
+	      tmp = gfc_build_array_ref (tmp, index, NULL);
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	      break;
+	    }
+	}
+    }
+
+  /* Set the target data pointer.  */
+  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+  gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
 /* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
    passed.  For whole arrays the descriptor is passed.  For array sections
@@ -4373,6 +4487,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   tree start;
   tree offset;
   int full;
+  bool subref_array_target = false;
 
   gcc_assert (ss != gfc_ss_terminator);
 
@@ -4395,7 +4510,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       gfc_conv_ss_descriptor (&se->pre, secss, 0);
       desc = info->descriptor;
 
-      need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+      subref_array_target = se->direct_byref && is_subref_array (expr);
+      need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+			&& !subref_array_target;
+
       if (need_tmp)
 	full = 0;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
@@ -4416,6 +4534,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	    {
 	      /* Copy the descriptor for pointer assignments.  */
 	      gfc_add_modify_expr (&se->pre, se->expr, desc);
+
+	      /* Add any offsets from subreferences.  */
+	      gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+				      subref_array_target, expr);
 	    }
 	  else if (se->want_pointer)
 	    {
@@ -4742,14 +4864,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       if (se->data_not_needed)
 	gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
       else
-	{
-	  /* Point the data pointer at the first element in the section.  */
-	  tmp = gfc_conv_array_data (desc);
-	  tmp = build_fold_indirect_ref (tmp);
-	  tmp = gfc_build_array_ref (tmp, offset);
-	  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
-	  gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
-	}
+	/* Point the data pointer at the first element in the section.  */
+	gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+				subref_array_target, expr);
 
       if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
 	  && !se->data_not_needed)
@@ -5082,7 +5199,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
       /* Build the body of the loop.  */
       gfc_init_block (&loopbody);
 
-      vref = gfc_build_array_ref (var, index);
+      vref = gfc_build_array_ref (var, index, NULL);
 
       if (purpose == COPY_ALLOC_COMP)
         {
@@ -5090,7 +5207,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  gfc_add_expr_to_block (&fnblock, tmp);
 
 	  tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
-	  dref = gfc_build_array_ref (tmp, index);
+	  dref = gfc_build_array_ref (tmp, index, NULL);
 	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
 	}
       else
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 926a239..854ca54 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1016,6 +1016,25 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  gcc_assert (!sym->value);
 	}
     }
+  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 (VAR_DECL, create_tmp_var_name ("span"),
+			 gfc_array_index_type);
+      gfc_finish_var_decl (span, sym);
+      TREE_STATIC (span) = 1;
+      DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+
+      GFC_DECL_SPAN (decl) = span;
+    }
+
   sym->backend_decl = decl;
 
   if (sym->attr.assign)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b6eb33a..f5d7c65 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -183,6 +183,15 @@ gfc_get_expr_charlen (gfc_expr *e)
   
   length = NULL; /* To silence compiler warning.  */
 
+  if (is_subref_array (e) && e->ts.cl->length)
+    {
+      gfc_se tmpse;
+      gfc_init_se (&tmpse, NULL);
+      gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
+      e->ts.cl->backend_decl = tmpse.expr;
+      return tmpse.expr;
+    }
+
   /* First candidate: if the variable is of type CHARACTER, the
      expression's length could be the length of the character
      variable.  */
@@ -207,6 +216,7 @@ gfc_get_expr_charlen (gfc_expr *e)
 	  /* We should never got substring references here.  These will be
 	     broken down by the scalarizer.  */
 	  gcc_unreachable ();
+	  break;
 	}
     }
 
@@ -270,7 +280,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
 	tmp = se->expr;
       else
 	tmp = build_fold_indirect_ref (se->expr);
-      tmp = gfc_build_array_ref (tmp, start.expr);
+      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
       se->expr = gfc_build_addr_expr (type, tmp);
     }
 
@@ -1782,15 +1792,13 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
   gfc_free_expr (expr);
 }
 
+
 /* Returns a reference to a temporary array into which a component of
    an actual argument derived type array is copied and then returned
-   after the function call.
-   TODO Get rid of this kludge, when array descriptors are capable of
-   handling arrays with a bigger stride in bytes than size.  */
-
+   after the function call.  */
 void
-gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
-		      int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
+			   int g77, sym_intent intent)
 {
   gfc_se lse;
   gfc_se rse;
@@ -1962,7 +1970,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 
   /* Now use the offset for the reference.  */
   tmp = build_fold_indirect_ref (info->data);
-  rse.expr = gfc_build_array_ref (tmp, tmp_index);
+  rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
 
   if (expr->ts.type == BT_CHARACTER)
     rse.string_length = expr->ts.cl->backend_decl;
@@ -2005,28 +2013,6 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
   return;
 }
 
-/* Is true if an array reference is followed by a component or substring
-   reference.  */
-
-bool
-is_aliased_array (gfc_expr * e)
-{
-  gfc_ref * ref;
-  bool seen_array;
-
-  seen_array = false;	
-  for (ref = e->ref; ref; ref = ref->next)
-    {
-      if (ref->type == REF_ARRAY
-	    && ref->u.ar.type != AR_ELEMENT)
-	seen_array = true;
-
-      if (seen_array
-	    && ref->type != REF_ARRAY)
-	return seen_array;
-    }
-  return false;
-}
 
 /* Generate the code for argument list functions.  */
 
@@ -2256,12 +2242,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      f = f || !sym->attr.always_explicit;
 
 	      if (e->expr_type == EXPR_VARIABLE
-		    && is_aliased_array (e))
+		    && is_subref_array (e))
 		/* 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
 		   written back after the procedure call.  */
-		gfc_conv_aliased_arg (&parmse, e, f,
+		gfc_conv_subref_array_arg (&parmse, e, f,
 			fsym ? fsym->attr.intent : INTENT_INOUT);
 	      else
 	        gfc_conv_array_parameter (&parmse, e, argss, f);
@@ -3471,6 +3457,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   stmtblock_t block;
   tree desc;
   tree tmp;
+  tree decl;
+
 
   gfc_start_block (&block);
 
@@ -3509,6 +3497,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  /* Assign directly to the pointer's descriptor.  */
           lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2, rss);
+
+	  /* If this is a subreference array pointer assignment, use the rhs
+	     element size for the lhs span.  */
+	  if (expr1->symtree->n.sym->attr.subref_array_pointer)
+	    {
+	      decl = expr1->symtree->n.sym->backend_decl;
+	      tmp = rss->data.info.descriptor;
+	      tmp = gfc_get_element_type (TREE_TYPE (tmp));
+	      tmp = size_in_bytes (tmp);
+	      tmp = fold_convert (gfc_array_index_type, tmp);
+	      gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
+	    }
+
 	  break;
 
 	default:
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 289c2d2..72875f1 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -724,11 +724,11 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
     {
       se.ss = gfc_walk_expr (e);
 
-      if (is_aliased_array (e))
+      if (is_subref_array (e))
 	{
 	  /* Use a temporary for components of arrays of derived types
 	     or substring array references.  */
-	  gfc_conv_aliased_arg (&se, e, 0,
+	  gfc_conv_subref_array_arg (&se, e, 0,
 		last_dt == READ ? INTENT_IN : INTENT_OUT);
 	  tmp = build_fold_indirect_ref (se.expr);
 	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
@@ -1330,7 +1330,7 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
      a RECORD_TYPE.  */
 
   if (array_flagged)
-    tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
+    tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
 
   /* Now build the address expression.  */
 
@@ -1964,7 +1964,9 @@ gfc_trans_transfer (gfc_code * code)
 	  gcc_assert (ref->type == REF_ARRAY);
 	}
 
-      if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
+      if (expr->ts.type != BT_DERIVED
+	    && ref && ref->next == NULL
+	    && !is_subref_array (expr))
 	{
 	  /* Get the descriptor.  */
 	  gfc_conv_expr_descriptor (&se, expr, ss);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index f900ec5..0bf0387 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1650,7 +1650,7 @@ gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
           /* If a mask was specified make the assignment conditional.  */
           if (mask)
             {
-              tmp = gfc_build_array_ref (mask, maskindex);
+              tmp = gfc_build_array_ref (mask, maskindex, NULL);
               body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
             }
         }
@@ -1729,7 +1729,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
       gfc_conv_expr (&lse, expr);
 
       /* Form the expression for the temporary.  */
-      tmp = gfc_build_array_ref (tmp1, count1);
+      tmp = gfc_build_array_ref (tmp1, count1, NULL);
 
       /* Use the scalar assignment as is.  */
       gfc_add_block_to_block (&block, &lse.pre);
@@ -1770,7 +1770,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
 
       /* Form the expression of the temporary.  */
       if (lss != gfc_ss_terminator)
-	rse.expr = gfc_build_array_ref (tmp1, count1);
+	rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
       /* Translate expr.  */
       gfc_conv_expr (&lse, expr);
 
@@ -1781,7 +1781,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
       /* Form the mask expression according to the mask tree list.  */
       if (wheremask)
 	{
-	  wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+	  wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
 	  if (invert)
 	    wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
 					 TREE_TYPE (wheremaskexpr),
@@ -1843,7 +1843,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
     {
       gfc_init_block (&body1);
       gfc_conv_expr (&rse, expr2);
-      lse.expr = gfc_build_array_ref (tmp1, count1);
+      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
     }
   else
     {
@@ -1867,7 +1867,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
       gfc_conv_expr (&rse, expr2);
 
       /* Form the expression of the temporary.  */
-      lse.expr = gfc_build_array_ref (tmp1, count1);
+      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
     }
 
   /* Use the scalar assignment.  */
@@ -1878,7 +1878,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
   /* Form the mask expression according to the mask tree list.  */
   if (wheremask)
     {
-      wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+      wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
       if (invert)
 	wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
 				     TREE_TYPE (wheremaskexpr),
@@ -2251,7 +2251,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 					    inner_size, NULL, block, &ptemp1);
       gfc_start_block (&body);
       gfc_init_se (&lse, NULL);
-      lse.expr = gfc_build_array_ref (tmp1, count);
+      lse.expr = gfc_build_array_ref (tmp1, count, NULL);
       gfc_init_se (&rse, NULL);
       rse.want_pointer = 1;
       gfc_conv_expr (&rse, expr2);
@@ -2278,7 +2278,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
       gfc_start_block (&body);
       gfc_init_se (&lse, NULL);
       gfc_init_se (&rse, NULL);
-      rse.expr = gfc_build_array_ref (tmp1, count);
+      rse.expr = gfc_build_array_ref (tmp1, count, NULL);
       lse.want_pointer = 1;
       gfc_conv_expr (&lse, expr1);
       gfc_add_block_to_block (&body, &lse.pre);
@@ -2320,7 +2320,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 					    inner_size, NULL, block, &ptemp1);
       gfc_start_block (&body);
       gfc_init_se (&lse, NULL);
-      lse.expr = gfc_build_array_ref (tmp1, count);
+      lse.expr = gfc_build_array_ref (tmp1, count, NULL);
       lse.direct_byref = 1;
       rss = gfc_walk_expr (expr2);
       gfc_conv_expr_descriptor (&lse, expr2, rss);
@@ -2343,7 +2343,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
       /* Reset count.  */
       gfc_add_modify_expr (block, count, gfc_index_zero_node);
 
-      parm = gfc_build_array_ref (tmp1, count);
+      parm = gfc_build_array_ref (tmp1, count, NULL);
       lss = gfc_walk_expr (expr1);
       gfc_init_se (&lse, NULL);
       gfc_conv_expr_descriptor (&lse, expr1, lss);
@@ -2596,7 +2596,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
       /* Store the mask.  */
       se.expr = convert (mask_type, se.expr);
 
-      tmp = gfc_build_array_ref (mask, maskindex);
+      tmp = gfc_build_array_ref (mask, maskindex, NULL);
       gfc_add_modify_expr (&body, tmp, se.expr);
 
       /* Advance to the next mask element.  */
@@ -2795,7 +2795,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
 
   if (mask && (cmask || pmask))
     {
-      tmp = gfc_build_array_ref (mask, count);
+      tmp = gfc_build_array_ref (mask, count, NULL);
       if (invert)
 	tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
       gfc_add_modify_expr (&body1, mtmp, tmp);
@@ -2803,7 +2803,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
 
   if (cmask)
     {
-      tmp1 = gfc_build_array_ref (cmask, count);
+      tmp1 = gfc_build_array_ref (cmask, count, NULL);
       tmp = cond;
       if (mask)
 	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
@@ -2812,7 +2812,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
 
   if (pmask)
     {
-      tmp1 = gfc_build_array_ref (pmask, count);
+      tmp1 = gfc_build_array_ref (pmask, count, NULL);
       tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
       if (mask)
 	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
@@ -2971,7 +2971,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
 
   /* Form the mask expression according to the mask.  */
   index = count1;
-  maskexpr = gfc_build_array_ref (mask, index);
+  maskexpr = gfc_build_array_ref (mask, index, NULL);
   if (invert)
     maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
 
@@ -3028,7 +3028,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
 
           /* Form the mask expression according to the mask tree list.  */
           index = count2;
-          maskexpr = gfc_build_array_ref (mask, index);
+          maskexpr = gfc_build_array_ref (mask, index, NULL);
 	  if (invert)
 	    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
 				    maskexpr);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index b9fd2df..0d036aa 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -309,9 +309,11 @@ gfc_build_addr_expr (tree type, tree t)
 /* Build an ARRAY_REF with its natural type.  */
 
 tree
-gfc_build_array_ref (tree base, tree offset)
+gfc_build_array_ref (tree base, tree offset, tree decl)
 {
   tree type = TREE_TYPE (base);
+  tree tmp;
+
   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
   type = TREE_TYPE (type);
 
@@ -321,7 +323,28 @@ gfc_build_array_ref (tree base, tree offset)
   /* Strip NON_LVALUE_EXPR nodes.  */
   STRIP_TYPE_NOPS (offset);
 
-  return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
+  /* 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
+		 || TREE_CODE (decl) == VAR_DECL
+		 || TREE_CODE (decl) == PARM_DECL)
+	&& GFC_DECL_SUBREF_ARRAY_P (decl)
+	&& !integer_zerop (GFC_DECL_SPAN(decl)))
+    {
+      offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			    offset, GFC_DECL_SPAN(decl));
+      tmp = gfc_build_addr_expr (pvoid_type_node, base);
+      tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
+			 tmp, fold_convert (sizetype, offset));
+      tmp = fold_convert (build_pointer_type (type), tmp);
+      if (!TYPE_STRING_FLAG (type))
+	tmp = build_fold_indirect_ref (tmp);
+      return tmp;
+    }
+  else
+    /* Otherwise use a straightforward array reference.  */
+    return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 }
 
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 389d037..58bdf3d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -316,8 +316,7 @@ tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
 int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
 			    tree);
 
-void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
-bool is_aliased_array (gfc_expr *);
+void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
 
 /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
 
@@ -379,7 +378,7 @@ tree gfc_get_function_decl (gfc_symbol *);
 tree gfc_build_addr_expr (tree, tree);
 
 /* Build an ARRAY_REF.  */
-tree gfc_build_array_ref (tree, tree);
+tree gfc_build_array_ref (tree, tree, tree);
 
 /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
 tree gfc_build_label_decl (tree);
@@ -593,11 +592,13 @@ struct lang_decl		GTY(())
      address of target label.  */
   tree stringlen;
   tree addr;
+  tree span;
 };
 
 
 #define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
 #define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+#define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
 #define GFC_DECL_SAVED_DESCRIPTOR(node) \
   (DECL_LANG_SPECIFIC(node)->saved_descriptor)
 #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
@@ -606,6 +607,7 @@ struct lang_decl		GTY(())
 #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)
 
 /* An array descriptor.  */
 #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2d61bae..496c309 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2007-09-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29396
+	PR fortran/29606
+	PR fortran/30625
+	PR fortran/30871
+	* gfortran.dg/subref_array_pointer_1.f90: New test.
+	* gfortran.dg/subref_array_pointer_2.f90: New test.
+
 2007-09-15  H.J. Lu  <hongjiu.lu@intel.com>
 
 	* gfortran.dg/nint_2.f90: Correct last change.
diff --git a/gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90 b/gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90
new file mode 100644
index 0000000..7bb0ff5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90
@@ -0,0 +1,59 @@
+! { dg-do run }
+! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+! to arrays with subreferences did not work.
+!
+  call pr29396
+  call pr29606
+  call pr30625
+  call pr30871
+contains
+  subroutine pr29396
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+    CHARACTER(LEN=2), DIMENSION(:), POINTER :: a 
+    CHARACTER(LEN=4), DIMENSION(3), TARGET :: b 
+    b=(/"bbbb","bbbb","bbbb"/) 
+    a=>b(:)(2:3) 
+    a="aa" 
+    IF (ANY(b.NE.(/"baab","baab","baab"/))) CALL ABORT() 
+  END subroutine
+
+  subroutine pr29606
+! Contributed by Daniel Franke <franke.daniel@gmail.com> 
+    TYPE foo
+      INTEGER :: value
+    END TYPE
+    TYPE foo_array
+      TYPE(foo), DIMENSION(:), POINTER :: array
+    END TYPE
+    TYPE(foo_array)                :: array_holder
+    INTEGER, DIMENSION(:), POINTER :: array_ptr
+    ALLOCATE( array_holder%array(3) )
+    array_holder%array = (/ foo(1), foo(2), foo(3) /)
+    array_ptr => array_holder%array%value
+    if (any (array_ptr .ne. (/1,2,3/))) call abort ()
+  END subroutine
+
+  subroutine pr30625
+! Contributed by Paul Thomas <pault@gcc.gnu.org> 
+    type :: a
+      real :: r = 3.14159
+      integer :: i = 42
+    end type a
+    type(a), target :: dt(2)
+    integer, pointer :: ip(:)
+    ip => dt%i
+    if (any (ip .ne. 42)) call abort ()
+  end subroutine
+
+  subroutine pr30871
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk> 
+    TYPE data
+      CHARACTER(LEN=3) :: A
+    END TYPE
+    TYPE(data), DIMENSION(10), TARGET :: Z
+    CHARACTER(LEN=1), DIMENSION(:), POINTER :: ptr
+    Z(:)%A="123"
+    ptr=>Z(:)%A(2:2)
+    if (any (ptr .ne. "2")) call abort ()
+  END subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90 b/gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90
new file mode 100644
index 0000000..97aabf1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90
@@ -0,0 +1,103 @@
+! { dg-do run }
+! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+! to arrays with subreferences did not work.
+!
+  type :: t
+    real :: r
+    integer :: i
+    character(3) :: chr
+  end type t
+
+  type :: t2
+    real :: r(2, 2)
+    integer :: i
+    character(3) :: chr
+  end type t2
+
+  type :: s
+    type(t), pointer :: t(:)
+  end type s
+
+  integer, parameter :: sh(2) = (/2,2/)
+  real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh)
+  real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh)
+
+  type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
+  character(4), target :: tar2(2) = (/"abcd","efgh"/)
+  type(s), target :: tar3
+  character(2), target :: tar4(2) = (/"ab","cd"/)
+  type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/)
+
+  integer, pointer :: ptr(:)
+  character(2), pointer :: ptr2(:)
+  real, pointer :: ptr3(:)
+
+!_______________component subreference___________
+  ptr => tar1%i
+  ptr = ptr + 1              ! check the scalarizer is OK
+
+  if (any (ptr .ne. (/3, 5/))) call abort ()
+  if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort ()
+  if (any (tar1%i .ne. (/3, 5/))) call abort ()
+
+! Make sure that the other components are not touched.
+  if (any (tar1%r .ne. (/1.0, 3.0/))) call abort ()
+  if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort ()
+
+! Check that the pointer is passed correctly as an actual argument.
+  call foo (ptr)
+  if (any (tar1%i .ne. (/2, 4/))) call abort ()
+
+! And that dummy pointers are OK too.
+  call bar (ptr)
+  if (any (tar1%i .ne. (/101, 103/))) call abort ()
+
+!_______________substring subreference___________
+  ptr2 => tar2(:)(2:3)
+  ptr2 = ptr2(:)(2:2)//"z"   ! again, check the scalarizer
+
+  if (any (ptr2 .ne. (/"cz", "gz"/))) call abort ()
+  if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort ()
+  if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort ()
+
+!_______________substring component subreference___________
+  ptr2 => tar1(:)%chr(1:2)
+  ptr2 = ptr2(:)(2:2)//"q"   ! yet again, check the scalarizer
+  if (any (ptr2 .ne. (/"bq","fq"/))) call abort ()
+  if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort ()
+
+!_______________trailing array element subreference___________
+  ptr3 => tar5%r(1,2)
+  ptr3 = (/99.0, 999.0/)
+  if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort ()
+  if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort ()
+
+!_______________forall assignment___________
+  ptr2 => tar2(:)(1:2)
+  forall (i = 1:2) ptr2(i)(1:1) = "z"
+  if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort ()
+
+!_______________something more complicated___________
+  tar3%t => tar1
+  ptr3 => tar3%t%r
+  ptr3 = cos (ptr3)
+  if (any (ptr3 .ne. (/cos(1.0_4), cos(3.0_4)/))) call abort ()
+
+  ptr2 => tar3%t(:)%chr(2:3)
+  ptr2 = " x"
+  if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort ()
+
+!_______________check non-subref works still___________
+  ptr2 => tar4
+  if (any (ptr2 .ne. (/"ab","cd"/))) call abort ()
+
+contains
+  subroutine foo (arg)
+    integer :: arg(:)
+    arg = arg - 1
+  end subroutine
+  subroutine bar (arg)
+    integer, pointer :: arg(:)
+    arg = arg + 99
+  end subroutine
+end