Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer

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

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

Dear All,

Encouraged by the response to the earlier version of the patch, please
find attached the final version that includes the promised cleanup;
except for the libgomp problem for which the fix remains the same.

Please find some descriptive material in the original submission below.

Two parts of the patch, most notably the new function
trans-array.c(gfc_get_descriptor_offsets_for_info), replace bits of
code that broke the API for access to array descriptor fields. Thanks
to Andre for spotting one of the sources of this API breaking, which
cost me a lot of time.

I presume that the module version number has to be bumped up?

Bootstraps and regtests on FC23/x86_64 - OK for trunk?

Regards

Paul

2017-07-01  Paul Thomas  <pault@gcc.gnu.org>

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

    * 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.
    (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.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-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_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.
    * trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
    as GFC_DECL_PTR_ARRAY_P.
    * 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.


2017-07-01  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/34640
    * 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_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-07-01  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/34640
    * libgfortran/libgfortran.h: Add span field to descriptor.

On 24 June 2017 at 11:48, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> Please find attached a draft patch for the above PR, together with PRs
> 40737, 55763, 57019 and 57116. These PRs constitute problems
> associated with the last F95 feature that gfortran does not completely
> implement.
>
> I want to sound out if this is acceptable as the way to fix these
> problems before going to the trouble of doing the final clean up;
> especially of trans.c (gfc_build_array_ref) and
> trans-array.c(build_array_ref).
>
> The problem concerns pointers to derived type array components. eg:
> pointer_array(:) => derived_array (:)%component
>
> At present gfortran uses a rather crude fix, where a 'span' variable
> with value of sizeof(element of derived_array) is used for pointer
> arithmetic to access elements of the array;
> &pointer_array(i) = &derived_array(1)%component + span*(i-1)
>
> The difficulty of using a variable 'span' is that it is not passed to
> procedures and it is not available to array pointer components. This
> patch fixes this by the introduction of a span field in the array
> descriptor. Note that this is only used for intrinsic type, pointer
> arrays in this version of the patch. A considerable simplification
> would arise from using the span field in class arrays too. This might
> well be one result of the clean up mentioned above.
>
> Tobias Burnus and I have been putting off fixing these PRs for a long
> time because of the pending array descriptor reform. However, work on
> fortran-dev has once again stopped and neither I nor, I think, anybody
> else has the time to restart this work anytime soon.
>
> pointer[1,2].f90 in the libgomp testsuite fail if this modification to
> array referencing is exposed to them. For the time being,
> trans-array.c(is_pointer_array) has:
> +   if (flag_openmp)
> +     return false;
> to switch off the modification. I will come back to this during the
> clean up, with the hope of putting it right.
>
> Bootstraps and regtests on FC23/x86_64 - OK to proceed to completion
> and submission?
>
> Paul
>
>
> 2017-06-24  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/34640
>     PR fortran/40737
>     PR fortran/55763
>     PR fortran/57019
>     PR fortran/57116
>
>     * 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_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.
>     (gfc_conv_array_ref): Similarly set 'decl'.
>     (gfc_array_allocate): Set the span field if this is a pointer
>     array.
>     (gfc_conv_expr_descriptor): Set the span field for pointer
>     assignments.
>     * trans-array.h: Prototypes for gfc_conv_descriptor_span_get
>     and gfc_conv_descriptor_span_set added.
>     * trans.c (gfc_build_array_ref): GFC_DECL_SUBREF_ARRAY_P change
>     to GFC_DECL_PTR_ARRAY_P and defreference if a PARM_DECL.
>     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 the
>     originating scope.
>     * trans-expr.c (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.
>     * trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
>     as GFC_DECL_PTR_ARRAY_P.
>     * 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): Jump one more in the DECL_CHAIN to
>     access the offset field.
>
>
> 2017-06-24  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/34640
>     * 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_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-06-24  Paul Thomas  <pault@gcc.gnu.org>
>
>     PR fortran/34640
>     * libgfortran/libgfortran.h: Add span field to descriptor.
>
>
> --
> "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: submit0107.diff --]
[-- Type: text/plain, Size: 60697 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 249865)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_array_dataptr_type (tree desc)
*** 125,132 ****
  #define DATA_FIELD 0
  #define OFFSET_FIELD 1
  #define DTYPE_FIELD 2
! #define DIMENSION_FIELD 3
! #define CAF_TOKEN_FIELD 4
  
  #define STRIDE_SUBFIELD 0
  #define LBOUND_SUBFIELD 1
--- 125,133 ----
  #define DATA_FIELD 0
  #define OFFSET_FIELD 1
  #define DTYPE_FIELD 2
! #define SPAN_FIELD 3
! #define DIMENSION_FIELD 4
! #define CAF_TOKEN_FIELD 5
  
  #define STRIDE_SUBFIELD 0
  #define LBOUND_SUBFIELD 1
*************** gfc_conv_descriptor_dtype (tree desc)
*** 244,249 ****
--- 245,280 ----
  			  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)
*************** gfc_conv_shift_descriptor_lbound (stmtbl
*** 466,476 ****
--- 497,537 ----
  }
  
  
+ /* 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
*************** gfc_add_ss_to_loop (gfc_loopinfo * loop,
*** 720,725 ****
--- 781,860 ----
  }
  
  
+ /* 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;
+ 
+   /* 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
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3239,3249 ****
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   if (expr && (is_subref_array (expr)
  	       || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
  					 || expr->expr_type == EXPR_FUNCTION))))
      decl = expr->symtree->n.sym->backend_decl;
  
    tmp = build_fold_indirect_ref_loc (input_location, info->data);
  
    /* Use the vptr 'size' field to access a class the element of a class
--- 3374,3400 ----
      index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
  			     index, info->offset);
  
!   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;
+ 	}
+       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
*************** build_array_ref (tree desc, tree offset,
*** 3288,3332 ****
  {
    tree tmp;
    tree type;
!   tree cdecl;
!   bool classarray = false;
  
    /* 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 (
  				  TREE_OPERAND (desc, 0)));
    else
!     cdecl = 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)
      {
!       type = TREE_TYPE (TREE_OPERAND (cdecl, 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;
      }
  
    tmp = gfc_conv_array_data (desc);
--- 3439,3465 ----
  {
    tree tmp;
    tree type;
!   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)))
!     cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
  				  TREE_OPERAND (desc, 0)));
    else
!     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 (cdesc))
!       && TREE_CODE (cdesc) == COMPONENT_REF)
      {
!       type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
        if (TYPE_CANONICAL (type)
  	  && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
! 	vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
      }
  
    tmp = gfc_conv_array_data (desc);
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3350,3355 ****
--- 3483,3489 ----
    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;
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3494,3501 ****
      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);
  }
  
  
--- 3628,3656 ----
      offset = fold_build2_loc (input_location, PLUS_EXPR,
  			      gfc_array_index_type, offset, cst_offset);
  
!   /* 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
! 	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);
  }
  
  
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5648,5653 ****
--- 5803,5816 ----
    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))
+     {
+       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)
      {
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6851,6856 ****
--- 7014,7023 ----
  	      /* 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)
  	    {
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6886,6893 ****
--- 7053,7070 ----
  	    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;
  	}
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7107,7115 ****
        desc = info->descriptor;
        if (se->direct_byref && !se->byref_noassign)
  	{
! 	  /* For pointer assignments we fill in the destination.  */
  	  parm = se->expr;
  	  parmtype = TREE_TYPE (parm);
  	}
        else
  	{
--- 7284,7296 ----
        desc = info->descriptor;
        if (se->direct_byref && !se->byref_noassign)
  	{
! 	  /* 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
  	{
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 249865)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_conv_array_ubound (tree, int);
*** 152,160 ****
--- 152,164 ----
  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);
*************** tree gfc_conv_descriptor_token (tree);
*** 165,170 ****
--- 169,175 ----
  
  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);
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 249865)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_addr_expr (tree type, tree t)
*** 305,310 ****
--- 305,371 ----
  }
  
  
+ 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_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+       && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ 	  || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF)
+       && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF
+ 	  || TREE_CODE (decl) == FUNCTION_DECL
+ 	  || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ 					== DECL_CONTEXT (decl)))
+     {
+       span = TYPE_MAXVAL (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
*************** gfc_build_array_ref (tree base, tree off
*** 312,318 ****
  {
    tree type = TREE_TYPE (base);
    tree tmp;
!   tree span;
  
    if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
      {
--- 373,379 ----
  {
    tree type = TREE_TYPE (base);
    tree tmp;
!   tree span = NULL_TREE;
  
    if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
      {
*************** gfc_build_array_ref (tree base, tree off
*** 331,407 ****
  
    type = TREE_TYPE (type);
  
-   /* Use pointer arithmetic for deferred character length array
-      references.  */
-   if (type && TREE_CODE (type) == ARRAY_TYPE
-       && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
-       && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type)))
- 	  || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF)
-       && decl
-       && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF
- 	  || TREE_CODE (decl) == FUNCTION_DECL
- 	  || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
- 					== DECL_CONTEXT (decl)))
-     span = TYPE_MAXVAL (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 ();
- 
        offset = fold_build2_loc (input_location, MULT_EXPR,
  				gfc_array_index_type,
  				offset, span);
--- 392,414 ----
  
    type = TREE_TYPE (type);
  
    if (DECL_P (base))
      TREE_ADDRESSABLE (base) = 1;
  
    /* Strip NON_LVALUE_EXPR nodes.  */
    STRIP_TYPE_NOPS (offset);
  
!   /* 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);
*************** gfc_build_array_ref (tree base, tree off
*** 412,419 ****
  	tmp = build_fold_indirect_ref_loc (input_location, tmp);
        return tmp;
      }
    else
-     /* Otherwise use a straightforward array reference.  */
      return build4_loc (input_location, ARRAY_REF, type, base, offset,
  		       NULL_TREE, NULL_TREE);
  }
--- 419,426 ----
  	tmp = build_fold_indirect_ref_loc (input_location, tmp);
        return tmp;
      }
+   /* Otherwise use a straightforward array reference.  */
    else
      return build4_loc (input_location, ARRAY_REF, type, base, offset,
  		       NULL_TREE, NULL_TREE);
  }
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 249865)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1517,1522 ****
--- 1517,1525 ----
        /* 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)
  	{
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1751,1777 ****
    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;
  
!       GFC_DECL_SPAN (decl) = span;
!       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
!     }
  
    if (sym->ts.type == BT_CLASS)
! 	GFC_DECL_CLASS(decl) = 1;
  
    sym->backend_decl = decl;
  
--- 1754,1770 ----
    if (sym->ts.type == BT_CHARACTER)
      /* Character variables need special handling.  */
      gfc_allocate_lang_decl (decl);
  
!   if (sym->assoc && sym->attr.subref_array_pointer)
!     sym->attr.pointer = 1;
  
!   if (sym->attr.pointer && sym->attr.dimension
!       && !sym->ts.deferred
!       && !sym->attr.select_type_temporary)
!     GFC_DECL_PTR_ARRAY_P (decl) = 1;
  
    if (sym->ts.type == BT_CLASS)
!     GFC_DECL_CLASS(decl) = 1;
  
    sym->backend_decl = decl;
  
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4269,4281 ****
        if (sym->assoc)
  	continue;
  
!       if (sym->attr.subref_array_pointer
! 	  && GFC_DECL_SPAN (sym->backend_decl)
! 	  && !TREE_STATIC (GFC_DECL_SPAN (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_add_init_cleanup (block, gfc_finish_block (&tmpblock),
  				NULL_TREE);
  	}
--- 4262,4276 ----
        if (sym->assoc)
  	continue;
  
!       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_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);
  	}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 249865)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8223,8229 ****
    stmtblock_t block;
    tree desc;
    tree tmp;
-   tree decl;
    bool scalar, non_proc_pointer_assign;
    gfc_ss *ss;
  
--- 8223,8228 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8412,8435 ****
  	  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)
  	    {
  	      rse.expr = NULL_TREE;
  	      rse.string_length = NULL_TREE;
--- 8411,8417 ----
  	  gfc_conv_expr_descriptor (&lse, expr2);
  	  strlen_rhs = lse.string_length;
  
! 	  if (expr1->ts.type == BT_CLASS)
  	    {
  	      rse.expr = NULL_TREE;
  	      rse.string_length = NULL_TREE;
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8446,8452 ****
  	    {
  	      rse.expr = gfc_class_data_get (rse.expr);
  	      gfc_add_modify (&lse.pre, desc, rse.expr);
! 	    }
  	  else
  	    {
  	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
--- 8428,8439 ----
  	    {
  	      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,
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8492,8498 ****
  		 converted in rse and now have to build the correct LHS
  		 descriptor for it.  */
  
! 	      tree dtype, data;
  	      tree offs, stride;
  	      tree lbound, ubound;
  
--- 8479,8485 ----
  		 converted in rse and now have to build the correct LHS
  		 descriptor for it.  */
  
! 	      tree dtype, data, span;
  	      tree offs, stride;
  	      tree lbound, ubound;
  
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8505,8510 ****
--- 8492,8509 ----
  	      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);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 249865)
--- gcc/fortran/trans.h	(working copy)
*************** struct GTY(()) lang_decl {
*** 982,988 ****
  #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_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
  #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
  
--- 982,988 ----
  #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_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)
  
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 249865)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** conv_expr_ref_to_caf_ref (stmtblock_t *b
*** 1225,1234 ****
  	      && 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  */);
  	      arr_desc_token_offset
  		  = compute_component_offset (arr_desc_token_offset,
  					      TREE_TYPE (tmp));
--- 1225,1233 ----
  	      && ref->u.c.component->attr.dimension)
  	    {
  	      tree arr_desc_token_offset;
! 	      /* 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));
*************** conv_isocbinding_subroutine (gfc_code *c
*** 8129,8134 ****
--- 8128,8138 ----
    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));
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 249865)
--- gcc/fortran/trans-io.c	(working copy)
*************** gfc_trans_transfer (gfc_code * code)
*** 2563,2568 ****
--- 2563,2574 ----
  	  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
*************** gfc_trans_transfer (gfc_code * code)
*** 2597,2602 ****
--- 2603,2609 ----
  	  goto finish_block_label;
  	}
  
+ scalarize:
        /* Initialize the scalarizer.  */
        ss = gfc_walk_expr (expr);
        gfc_init_loopinfo (&loop);
*************** gfc_trans_transfer (gfc_code * code)
*** 2612,2618 ****
--- 2619,2627 ----
  
        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
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 249865)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1606,1612 ****
  	      : 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);
  	}
  
        /* Done, register stuff as init / cleanup code.  */
--- 1606,1612 ----
  	      : 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_conv_descriptor_span_set (&se.pre, desc, tmp);
  	}
  
        /* Done, register stuff as init / cleanup code.  */
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c	(revision 249865)
--- gcc/fortran/trans-types.c	(working copy)
*************** along with GCC; see the file COPYING3.
*** 35,40 ****
--- 35,41 ----
  #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.  */
  \f
  
*************** gfc_get_array_descriptor_base (int dimen
*** 1782,1787 ****
--- 1783,1794 ----
  				    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)
      {
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2708,2713 ****
--- 2715,2725 ----
        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)
*************** gfc_get_array_descr_info (const_tree typ
*** 3146,3152 ****
  {
    int rank, dim;
    bool indirect = false;
!   tree etype, ptype, field, t, base_decl;
    tree data_off, dim_off, dtype_off, dim_size, elem_size;
    tree lower_suboff, upper_suboff, stride_suboff;
  
--- 3158,3164 ----
  {
    int rank, dim;
    bool indirect = false;
!   tree etype, ptype, t, base_decl;
    tree data_off, dim_off, dtype_off, dim_size, elem_size;
    tree lower_suboff, upper_suboff, stride_suboff;
  
*************** gfc_get_array_descr_info (const_tree typ
*** 3203,3226 ****
    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);
  
    t = base_decl;
    if (!integer_zerop (data_off))
--- 3215,3225 ----
    if (indirect)
      base_decl = build1 (INDIRECT_REF, ptype, base_decl);
  
!   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))
Index: gcc/testsuite/gfortran.dg/assumed_type_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_type_2.f90	(revision 249865)
--- gcc/testsuite/gfortran.dg/assumed_type_2.f90	(working copy)
*************** end
*** 151,159 ****
  ! { 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 .&\\(.\\(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 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" } }
  
--- 151,159 ----
  ! { 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..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 .\\) .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" } }
  
Index: gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
===================================================================
*** gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95	(revision 249865)
--- gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95	(working copy)
*************** program main
*** 16,20 ****
  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" } }
--- 16,20 ----
  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" 4 "ealias" } }
! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } }
Index: gcc/testsuite/gfortran.dg/no_arg_check_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/no_arg_check_2.f90	(revision 249865)
--- gcc/testsuite/gfortran.dg/no_arg_check_2.f90	(working copy)
*************** end
*** 133,141 ****
  ! { 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 .&\\(.\\(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 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" } }
  
--- 133,141 ----
  ! { 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..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 .\\) .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" } }
  
Index: gcc/testsuite/gfortran.dg/pointer_array_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_1.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_1.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_2.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_2.f90	(working copy)
***************
*** 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
+ 
Index: gcc/testsuite/gfortran.dg/pointer_array_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_3.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_3.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_4.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_4.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_5.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_5.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_6.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_6.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_component_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_component_1.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_component_1.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/pointer_array_component_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_component_2.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_component_2.f90	(working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
===================================================================
*** gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95	(revision 249865)
--- gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95	(working copy)
*************** program main
*** 16,20 ****
  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" } }
--- 16,20 ----
  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" 4 "ealias" } }
! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } }
Index: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h	(revision 249865)
--- libgfortran/libgfortran.h	(working copy)
*************** struct {\
*** 339,344 ****
--- 339,345 ----
    type *base_addr;\
    size_t offset;\
    index_type dtype;\
+   index_type span;\
    descriptor_dimension dim[r];\
  }