Re: [Patch, fortran] 99307 - FAIL: gfortran.dg/class_assign_4.f90 execution test

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 4812 bytes --]

Tobias noticed a major technical fault with the resubmission below: I
forgot to attach the patch :-(

Please find it attached this time.

Paul

On Tue, 6 Apr 2021 at 18:08, Paul Richard Thomas <
paul.richard.thomas@gmail.com> wrote:

> Hi Tobias,
>
> I believe that the attached fixes the problems that you found with
> gfc_find_and_cut_at_last_class_ref.
>
> I will test:
>    type1%type%array_class2 → NULL is returned  (why?)
>    class1%type%array_class2 → ts = class1 but array2_class is used later
> on (ups!)
>    class1%...%scalar_class2 → ts = class1 but scalar_class2 is used
>
> The ChangeLogs remain the same, apart from the date.
>
> Regtests OK on FC33/x86_64.
>
> Paul
>
>
> On Mon, 29 Mar 2021 at 14:58, Tobias Burnus <tobias@codesourcery.com>
> wrote:
>
>> Hi all,
>>
>> as preremark I want to note that the testcase class_assign_4.f90
>> was added for PR83118/PR96012 (fixes problems in handling class objects,
>> Dec 18, 2020)
>> and got revised for PR99124 (class defined operators, Feb 23, 2021).
>> Both patches were then also applied to GCC 9 and 10.
>>
>> On 26.03.21 17:30, Paul Richard Thomas via Gcc-patches wrote:
>> > This patch comes in two versions: submit.diff with Change.Logs or
>> > submit2.diff with Change2.Logs.
>> > The first fixes the problem by changing array temporaries from class
>> > expressions into class temporaries. This permits the use of
>> > gfc_get_class_from_expr to obtain the vptr for these temporaries and all
>> > the good things that come with that when handling dynamic types. The
>> second
>> > part of the fix is to use the array element length from the class
>> > descriptor, when reallocating on assignment. This is needed because the
>> > vptr is being set too early. I will set about trying to track down why
>> this
>> > is happening and fix it after release.
>> >
>> > The second version does the same as the first but puts in place a load
>> of
>> > tidying up that is permitted by the fix to class array temporaries.
>>
>> > I couldn't readily see how to prepare a testcase - ideas?
>> > Both regtest on FC33/x86_64. The first was tested by Dominique (see the
>> > PR). OK for master?
>>
>> Typo – underscore-'c' should be a dot-'c' – both changelog files
>>
>> >       * trans-expr_c (gfc_trans_scalar_assign): Make use of pre and
>>
>> I think the second longer version is nicer in general, but at least for
>> GCC 9/GCC10 the first version is simpler and, hence, less error prone.
>>
>> As you only ask about mainline, I would prefer the second one.
>>
>> However, I am not happy about gfc_find_and_cut_at_last_class_ref:
>>
>> > + of refs following. If ts is non-null the cut is at the class entity
>> > + or component that is followed by an array reference, which is not +
>> > an element. */ ... + + if (ts) + { + if (e->symtree + &&
>> > e->symtree->n.sym->ts.type == BT_CLASS) + *ts =
>> > &e->symtree->n.sym->ts; + else + *ts = NULL; + } + for (ref = e->ref;
>> > ref; ref = ref->next) { + if (ts && ref->type == REF_COMPONENT + &&
>> > ref->u.c.component->ts.type == BT_CLASS + && ref->next &&
>> > ref->next->type == REF_COMPONENT + && strcmp
>> > (ref->next->u.c.component->name, "_data") == 0 + && ref->next->next +
>> > && ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.type
>> > != AR_ELEMENT) + { + *ts = &ref->u.c.component->ts; + class_ref = ref;
>> > + break; + } + + if (ts && *ts == NULL) + return NULL; +
>> Namely, if there is:
>>    type1%array_class2 → array_class2 is used for 'ts' and later (ok)
>>    type1%type%array_class2 → NULL is returned  (why?)
>>    class1%type%array_class2 → ts = class1 but array2_class is used later
>> on (ups!)
>>    class1%...%scalar_class2 → ts = class1 but scalar_class2 is used
>> etc.
>>
>> Thus this either needs to be cleaned up (separate 'ref' loop for
>> ts != NULL) – including the wording in the description which tells what
>> happens if 'ts' is passed as arg but the expr has rank == 0 – and
>> what value is assigned to 'ts'. (You can then also fix 'class.c::' to
>> 'class.c: ' in the description above the function.)
>>
>> Alternatively, you can leave the current code ref handling code in place
>> at build_class_array_ref, which might be the simpler alternative.
>>
>> Otherwise, it looks sensible to me.
>>
>> Tobias
>>
>> -----------------
>> Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München
>> Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank
>> Thürauf
>>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough" -
> Albert Einstein
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein

[-- Attachment #2: submit3.diff --]
[-- Type: text/x-patch, Size: 18026 bytes --]

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index be5eb89350f..ca90142530c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1403,9 +1403,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
 
-  info->descriptor = desc;
-  size = gfc_index_one_node;
-
   /* Emit a DECL_EXPR for the variable sized array type in
      GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
      sizes works correctly.  */
@@ -1416,9 +1413,40 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
 				      arraytype, TYPE_NAME (arraytype)));
 
-  /* Fill in the array dtype.  */
-  tmp = gfc_conv_descriptor_dtype (desc);
-  gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  if (class_expr != NULL_TREE)
+    {
+      tree class_data;
+      tree dtype;
+
+      /* Create a class temporary.  */
+      tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
+      gfc_add_modify (pre, tmp, class_expr);
+
+      /* Assign the new descriptor to the _data field. This allows the
+	 vptr _copy to be used for scalarized assignment since the class
+	 temporary can be found from the descriptor.  */
+      class_data = gfc_class_data_get (tmp);
+      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+			     TREE_TYPE (desc), desc);
+      gfc_add_modify (pre, class_data, tmp);
+
+      /* Take the dtype from the class expression.  */
+      dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
+      tmp = gfc_conv_descriptor_dtype (class_data);
+      gfc_add_modify (pre, tmp, dtype);
+
+      /* Point desc to the class _data field.  */
+      desc = class_data;
+    }
+  else
+    {
+      /* Fill in the array dtype.  */
+      tmp = gfc_conv_descriptor_dtype (desc);
+      gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+    }
+
+  info->descriptor = desc;
+  size = gfc_index_one_node;
 
   /*
      Fill in the bounds and stride.  This is a packed array, so:
@@ -3424,134 +3452,73 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
 static bool
 build_class_array_ref (gfc_se *se, tree base, tree index)
 {
-  tree type;
   tree size;
-  tree offset;
   tree decl = NULL_TREE;
   tree tmp;
   gfc_expr *expr = se->ss->info->expr;
-  gfc_ref *ref;
-  gfc_ref *class_ref = NULL;
+  gfc_expr *class_expr;
   gfc_typespec *ts;
+  gfc_symbol *sym;
 
-  if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
-      && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
-      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
-    decl = se->expr;
+  tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
+
+  if (tmp != NULL_TREE)
+    decl = tmp;
   else
     {
-      if (expr == NULL
+      /* The base expression does not contain a class component, either
+	 because it is a temporary array or array descriptor.  Class
+	 array functions are correctly resolved above.  */
+      if (!expr
 	  || (expr->ts.type != BT_CLASS
-	      && !gfc_is_class_array_function (expr)
 	      && !gfc_is_class_array_ref (expr, NULL)))
 	return false;
 
-      if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
-	ts = &expr->symtree->n.sym->ts;
-      else
-	ts = NULL;
-
-      for (ref = expr->ref; ref; ref = ref->next)
-	{
-	  if (ref->type == REF_COMPONENT
-	      && ref->u.c.component->ts.type == BT_CLASS
-	      && ref->next && ref->next->type == REF_COMPONENT
-	      && strcmp (ref->next->u.c.component->name, "_data") == 0
-	      && ref->next->next
-	      && ref->next->next->type == REF_ARRAY
-	      && ref->next->next->u.ar.type != AR_ELEMENT)
-	    {
-	      ts = &ref->u.c.component->ts;
-	      class_ref = ref;
-	      break;
-	    }
-	}
+      /* Obtain the expression for the class entity or component that is
+	 followed by an array reference, which is not an element, so that
+	 the span of the array can be obtained.  */
+      class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
 
-      if (ts == NULL)
+      if (!ts)
 	return false;
-    }
 
-  if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
-      && expr->symtree->n.sym == expr->symtree->n.sym->result
-      && expr->symtree->n.sym->backend_decl == current_function_decl)
-    {
-      decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
-    }
-  else if (expr && gfc_is_class_array_function (expr))
-    {
-      size = NULL_TREE;
-      decl = NULL_TREE;
-      for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
-	{
-	  tree type;
-	  type = TREE_TYPE (tmp);
-	  while (type)
-	    {
-	      if (GFC_CLASS_TYPE_P (type))
-		decl = tmp;
-	      if (type != TYPE_CANONICAL (type))
-		type = TYPE_CANONICAL (type);
-	      else
-		type = NULL_TREE;
-	    }
-	  if (VAR_P (tmp))
-	    break;
+      sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
+      if (sym && sym->attr.function
+	  && sym == sym->result
+	  && sym->backend_decl == current_function_decl)
+	/* The temporary is the data field of the class data component
+	   of the current function.  */
+	decl = gfc_get_fake_result_decl (sym, 0);
+      else if (sym)
+	{
+	  if (decl == NULL_TREE)
+	    decl = expr->symtree->n.sym->backend_decl;
+	  /* For class arrays the tree containing the class is stored in
+	     GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
+	     For all others it's sym's backend_decl directly.  */
+	  if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+	    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
 	}
+      else
+	decl = gfc_get_class_from_gfc_expr (class_expr);
 
-      if (decl == NULL_TREE)
-	return false;
+      if (POINTER_TYPE_P (TREE_TYPE (decl)))
+	decl = build_fold_indirect_ref_loc (input_location, decl);
 
-      se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
-    }
-  else if (class_ref == NULL)
-    {
-      if (decl == NULL_TREE)
-	decl = expr->symtree->n.sym->backend_decl;
-      /* For class arrays the tree containing the class is stored in
-	 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
-	 For all others it's sym's backend_decl directly.  */
-      if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
-	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
-    }
-  else
-    {
-      /* Remove everything after the last class reference, convert the
-	 expression and then recover its tailend once more.  */
-      gfc_se tmpse;
-      ref = class_ref->next;
-      class_ref->next = NULL;
-      gfc_init_se (&tmpse, NULL);
-      gfc_conv_expr (&tmpse, expr);
-      gfc_add_block_to_block (&se->pre, &tmpse.pre);
-      decl = tmpse.expr;
-      class_ref->next = ref;
+      if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+	return false;
     }
 
-  if (POINTER_TYPE_P (TREE_TYPE (decl)))
-    decl = build_fold_indirect_ref_loc (input_location, decl);
-
-  if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
-    return false;
+  se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
 
   size = gfc_class_vtab_size_get (decl);
-
   /* For unlimited polymorphic entities then _len component needs to be
      multiplied with the size.  */
   size = gfc_resize_class_size_with_len (&se->pre, decl, size);
-
   size = fold_convert (TREE_TYPE (index), size);
 
-  /* Build the address of the element.  */
-  type = TREE_TYPE (TREE_TYPE (base));
-  offset = fold_build2_loc (input_location, MULT_EXPR,
-			    gfc_array_index_type,
-			    index, size);
-  tmp = gfc_build_addr_expr (pvoid_type_node, base);
-  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
-  tmp = fold_convert (build_pointer_type (type), tmp);
-
   /* Return the element in the se expression.  */
-  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  se->expr = gfc_build_spanned_array_ref (base, index, size);
   return true;
 }
 
@@ -10280,23 +10247,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
     }
   else if (expr1->ts.type == BT_CLASS)
     {
-      tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
-      if (tmp == NULL_TREE)
-	tmp = gfc_get_class_from_gfc_expr (expr1);
-
-      if (tmp != NULL_TREE)
-	{
-	  tmp2 = gfc_class_vptr_get (tmp);
-	  cond = fold_build2_loc (input_location, NE_EXPR,
-				  logical_type_node, tmp2,
-				  build_int_cst (TREE_TYPE (tmp2), 0));
-	  elemsize1 = gfc_class_vtab_size_get (tmp);
-	  elemsize1 = fold_build3_loc (input_location, COND_EXPR,
-				      gfc_array_index_type, cond,
-				      elemsize1, gfc_index_zero_node);
-	}
-      else
-	elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+      /* Unfortunately, the lhs vptr is set too early in many cases.
+	 Play it safe by using the descriptor element length.  */
+      tmp = gfc_conv_descriptor_elem_len (desc);
+      elemsize1 = fold_convert (gfc_array_index_type, tmp);
     }
   else
     elemsize1 = NULL_TREE;
@@ -10770,11 +10724,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 
 
   /* We already set the dtype in the case of deferred character
-     length arrays and unlimited polymorphic arrays.  */
+     length arrays and class lvalues.  */
   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
 	&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
 	    || coarray))
-      && !UNLIMITED_POLY (expr1))
+      && expr1->ts.type != BT_CLASS)
     {
       tmp = gfc_conv_descriptor_dtype (desc);
       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2fa17b36c03..213f32b0a67 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -380,15 +380,20 @@ gfc_vptr_size_get (tree vptr)
 #undef VTABLE_FINAL_FIELD
 
 
-/* Search for the last _class ref in the chain of references of this
-   expression and cut the chain there.  Albeit this routine is similiar
-   to class.c::gfc_add_component_ref (), is there a significant
-   difference: gfc_add_component_ref () concentrates on an array ref to
-   be the last ref in the chain.  This routine is oblivious to the kind
-   of refs following.  */
+/* IF ts is null (default), search for the last _class ref in the chain
+   of references of the expression and cut the chain there.  Although
+   this routine is similiar to class.c:gfc_add_component_ref (), there
+   is a significant difference: gfc_add_component_ref () concentrates
+   on an array ref that is the last ref in the chain and is oblivious
+   to the kind of refs following.
+   ELSE IF ts is non-null the cut is at the class entity or component
+   that is followed by an array reference, which is not an element.
+   These calls come from trans-array.c:build_class_array_ref, which
+   handles scalarized class array references.*/
 
 gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
+				    gfc_typespec **ts)
 {
   gfc_expr *base_expr;
   gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
@@ -396,27 +401,59 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
   /* Find the last class reference.  */
   class_ref = NULL;
   array_ref = NULL;
-  for (ref = e->ref; ref; ref = ref->next)
+
+  if (ts)
     {
-      if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
-	array_ref = ref;
+      if (e->symtree
+	  && e->symtree->n.sym->ts.type == BT_CLASS)
+	*ts = &e->symtree->n.sym->ts;
+      else
+	*ts = NULL;
+    }
 
-      if (ref->type == REF_COMPONENT
-	  && ref->u.c.component->ts.type == BT_CLASS)
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ts)
 	{
-	  /* Component to the right of a part reference with nonzero rank
-	     must not have the ALLOCATABLE attribute.  If attempts are
-	     made to reference such a component reference, an error results
-	     followed by an ICE.  */
-	  if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
-	    return NULL;
-	  class_ref = ref;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS
+	      && ref->next && ref->next->type == REF_COMPONENT
+	      && !strcmp (ref->next->u.c.component->name, "_data")
+	      && ref->next->next
+	      && ref->next->next->type == REF_ARRAY
+	      && ref->next->next->u.ar.type != AR_ELEMENT)
+	    {
+	      *ts = &ref->u.c.component->ts;
+	      class_ref = ref;
+	      break;
+	    }
+
+	  if (ref->next == NULL)
+	    break;
 	}
+      else
+	{
+	  if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+	    array_ref = ref;
 
-      if (ref->next == NULL)
-	break;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS)
+	    {
+	      /* Component to the right of a part reference with nonzero
+		 rank must not have the ALLOCATABLE attribute.  If attempts
+		 are made to reference such a component reference, an error
+		 results followed by an ICE.  */
+	      if (array_ref
+		  && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+		return NULL;
+	      class_ref = ref;
+	    }
+	}
     }
 
+  if (ts && *ts == NULL)
+    return NULL;
+
   /* Remove and store all subsequent references after the
      CLASS reference.  */
   if (class_ref)
@@ -10005,17 +10042,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_modify (&block, lse->expr, tmp);
     }
   /* If possible use the rhs vptr copy with trans_scalar_class_assign....  */
-  else if (ts.type == BT_CLASS
-	   && !trans_scalar_class_assign (&block, lse, rse))
+  else if (ts.type == BT_CLASS)
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
-      /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
-	 for the lhs which ensures that class data rhs cast as a string assigns
-	 correctly.  */
-      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
-			     TREE_TYPE (rse->expr), lse->expr);
-      gfc_add_modify (&block, tmp, rse->expr);
+
+      if (!trans_scalar_class_assign (&block, lse, rse))
+	{
+	  /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+	  for the lhs which ensures that class data rhs cast as a string assigns
+	  correctly.  */
+	  tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+				 TREE_TYPE (rse->expr), lse->expr);
+	  gfc_add_modify (&block, tmp, rse->expr);
+	}
     }
   else if (ts.type != BT_CLASS)
     {
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index ab53fc5f441..9e8e8619ff8 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -422,6 +422,9 @@ get_array_span (tree type, tree decl)
 		return NULL_TREE;
 	    }
 	  span = gfc_class_vtab_size_get (decl);
+	  /* For unlimited polymorphic entities then _len component needs
+	     to be multiplied with the size.  */
+	  span = gfc_resize_class_size_with_len (NULL, decl, span);
 	}
       else if (GFC_DECL_PTR_ARRAY_P (decl))
 	{
@@ -439,13 +442,31 @@ get_array_span (tree type, tree decl)
 }
 
 
+tree
+gfc_build_spanned_array_ref (tree base, tree offset, tree span)
+{
+  tree type;
+  tree tmp;
+  type = TREE_TYPE (TREE_TYPE (base));
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+			    gfc_array_index_type,
+			    offset, span);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+  if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
+      || !TYPE_STRING_FLAG (type))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  return tmp;
+}
+
+
 /* Build an ARRAY_REF with its natural type.  */
 
 tree
 gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 {
   tree type = TREE_TYPE (base);
-  tree tmp;
   tree span = NULL_TREE;
 
   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
@@ -488,18 +509,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
   /* 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);
-      tmp = gfc_build_addr_expr (pvoid_type_node, base);
-      tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
-      tmp = fold_convert (build_pointer_type (type), tmp);
-      if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
-	  || !TYPE_STRING_FLAG (type))
-	tmp = build_fold_indirect_ref_loc (input_location, tmp);
-      return tmp;
-    }
+    return gfc_build_spanned_array_ref (base, offset, span);
   /* Otherwise use a straightforward array reference.  */
   else
     return build4_loc (input_location, ARRAY_REF, type, base, offset,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 44cbfb63f39..8c6f82ff1b1 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -424,7 +424,8 @@ tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
 tree gfc_class_len_or_zero_get (tree);
 tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
-gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false);
+gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false,
+					       gfc_typespec **ts = NULL);
 /* Get an accessor to the class' vtab's * field, when a class handle is
    available.  */
 tree gfc_class_vtab_hash_get (tree);
@@ -622,6 +623,9 @@ tree gfc_build_addr_expr (tree, tree);
 /* Build an ARRAY_REF.  */
 tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE);
 
+/* Build an array ref using pointer arithmetic.  */
+tree gfc_build_spanned_array_ref (tree base, tree offset, tree span);
+
 /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
 tree gfc_build_label_decl (tree);