This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR29396 PR29606 PR30625 and PR30871 - subreference array pointers.


:ADDPATCH fortran:

This is a first stab at fixing these beasts. I would be the first to admit that this might not be the most efficient way of going about the job but it does leave the rest of gfortran's functionality untouched. Also, the patch is incomplete. Pointer references to substrings of components of arrays of derived types do not work and, without having tried it, I am sure that WHERE and FORALL masks will do odd things if they are such pointers. The former is something that I will work on right away, after writing a PR, and the latter is a longer term TODO.

The patch functions by adding a 'span' field to the lang_decl structure, which stores the size of the target array elements. The rhs of a pointer assignment is converted to a descriptor, whose data pointer is to the subreference of the first element of the array. gfc_build_array_ref has then been modified to take a look at the declaration for the array; if it is a pointer to a subreference array, the offset is calculated in bytes and the element extracted by explicit pointer arithmetic. The treatment of these pointers as actual arguments is very conservative - they are always copy-in/copy-out. Doubtless cleverer things can be done in teh fullness of time.

At present, very few references to gfc_build_array_ref have been updated to supply the variable declaration. However, these are sufficient to provide the basic functionality. I am rather sure that the problem with substrings of components, mentioned above, lies in resolve.c. However, I just do not have time to deal with it now.

The testcase is an amalgam of the PR testcases, together with some testing that the target is modified as it should be and that various forms of pointer reference work correctly.

It is my opinion that this patch is ready for 4.3 simply because it provides an extra functionality that is ringfenced by specific tests. Such pointer assignements, at present, either lead to ICEs or wrong code. Hence, even if it is not in its final form, it will not break anything, whilst filling in the missing f95 feature.

Regtested on Cygwin_NT/amd64 - OK for trunk..... before 09/10 :-) ?

Paul

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

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

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

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


Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 128135)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_descriptor_dimension (tree desc
*** 245,251 ****
  	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
  
    tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
!   tmp = gfc_build_array_ref (tmp, dim);
    return tmp;
  }
  
--- 245,251 ----
  	  && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
  
    tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
!   tmp = gfc_build_array_ref (tmp, dim, NULL);
    return tmp;
  }
  
*************** gfc_trans_array_ctor_element (stmtblock_
*** 961,967 ****
  
    /* Store the value.  */
    tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
!   tmp = gfc_build_array_ref (tmp, offset);
    if (expr->ts.type == BT_CHARACTER)
      {
        gfc_conv_string_parameter (se);
--- 961,967 ----
  
    /* Store the value.  */
    tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
!   tmp = gfc_build_array_ref (tmp, offset, NULL);
    if (expr->ts.type == BT_CHARACTER)
      {
        gfc_conv_string_parameter (se);
*************** gfc_trans_array_constructor_value (stmtb
*** 1181,1187 ****
  	      /* Use BUILTIN_MEMCPY to assign the values.  */
  	      tmp = gfc_conv_descriptor_data_get (desc);
  	      tmp = build_fold_indirect_ref (tmp);
! 	      tmp = gfc_build_array_ref (tmp, *poffset);
  	      tmp = build_fold_addr_expr (tmp);
  	      init = build_fold_addr_expr (init);
  
--- 1181,1187 ----
  	      /* Use BUILTIN_MEMCPY to assign the values.  */
  	      tmp = gfc_conv_descriptor_data_get (desc);
  	      tmp = build_fold_indirect_ref (tmp);
! 	      tmp = gfc_build_array_ref (tmp, *poffset, NULL);
  	      tmp = build_fold_addr_expr (tmp);
  	      init = build_fold_addr_expr (init);
  
*************** gfc_conv_array_index_offset (gfc_se * se
*** 2167,2173 ****
  
  	  /* Read the vector to get an index into info->descriptor.  */
  	  data = build_fold_indirect_ref (gfc_conv_array_data (desc));
! 	  index = gfc_build_array_ref (data, index);
  	  index = gfc_evaluate_now (index, &se->pre);
  
  	  /* Do any bounds checking on the final info->descriptor index.  */
--- 2167,2173 ----
  
  	  /* Read the vector to get an index into info->descriptor.  */
  	  data = build_fold_indirect_ref (gfc_conv_array_data (desc));
! 	  index = gfc_build_array_ref (data, index, NULL);
  	  index = gfc_evaluate_now (index, &se->pre);
  
  	  /* Do any bounds checking on the final info->descriptor index.  */
*************** static void
*** 2219,2224 ****
--- 2219,2225 ----
  gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
  {
    gfc_ss_info *info;
+   tree decl = NULL_TREE;
    tree index;
    tree tmp;
    int n;
*************** gfc_conv_scalarized_array_ref (gfc_se * 
*** 2236,2243 ****
    if (!integer_zerop (info->offset))
      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
  
    tmp = build_fold_indirect_ref (info->data);
!   se->expr = gfc_build_array_ref (tmp, index);
  }
  
  
--- 2237,2247 ----
    if (!integer_zerop (info->offset))
      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
  
+   if (se->ss->expr && is_subref_array (se->ss->expr))
+     decl = se->ss->expr->symtree->n.sym->backend_decl;
+ 
    tmp = build_fold_indirect_ref (info->data);
!   se->expr = gfc_build_array_ref (tmp, index, decl);
  }
  
  
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 2338,2348 ****
    tmp = gfc_conv_array_offset (se->expr);
    if (!integer_zerop (tmp))
      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
!       
    /* Access the calculated element.  */
    tmp = gfc_conv_array_data (se->expr);
    tmp = build_fold_indirect_ref (tmp);
!   se->expr = gfc_build_array_ref (tmp, index);
  }
  
  
--- 2342,2352 ----
    tmp = gfc_conv_array_offset (se->expr);
    if (!integer_zerop (tmp))
      index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
! 
    /* Access the calculated element.  */
    tmp = gfc_conv_array_data (se->expr);
    tmp = build_fold_indirect_ref (tmp);
!   se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
  }
  
  
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4373,4378 ****
--- 4377,4383 ----
    tree start;
    tree offset;
    int full;
+   bool subref_array_target = false;
  
    gcc_assert (ss != gfc_ss_terminator);
  
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4395,4401 ****
        gfc_conv_ss_descriptor (&se->pre, secss, 0);
        desc = info->descriptor;
  
!       need_tmp = gfc_ref_needs_temporary_p (expr->ref);
        if (need_tmp)
  	full = 0;
        else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
--- 4400,4409 ----
        gfc_conv_ss_descriptor (&se->pre, secss, 0);
        desc = info->descriptor;
  
!       subref_array_target = se->direct_byref && is_subref_array (expr);
!       need_tmp = gfc_ref_needs_temporary_p (expr->ref)
! 			&& !subref_array_target;
! 
        if (need_tmp)
  	full = 0;
        else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4746,4752 ****
  	  /* Point the data pointer at the first element in the section.  */
  	  tmp = gfc_conv_array_data (desc);
  	  tmp = build_fold_indirect_ref (tmp);
! 	  tmp = gfc_build_array_ref (tmp, offset);
  	  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
  	  gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
  	}
--- 4754,4802 ----
  	  /* Point the data pointer at the first element in the section.  */
  	  tmp = gfc_conv_array_data (desc);
  	  tmp = build_fold_indirect_ref (tmp);
! 	  tmp = gfc_build_array_ref (tmp, offset, NULL);
! 
! 	  /* Offset the data pointer for pointer assignments from arrays with
! 	     subreferences; eg. my_integer => my_type(:)%integer_component.  */
! 	  if (subref_array_target)
! 	    {
! 	      gfc_ref *tmp_ref;
! 	      tree field;
! 	      gfc_se start;
! 
! 	      /* Go past the array reference.  */
! 	      for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
! 		if (tmp_ref->type == REF_ARRAY)
! 		  {
! 		    tmp_ref = tmp_ref->next;
! 		    break;
! 		  }
! 
! 	      /* Calculate the offset for each subreference.  */
! 	      for (tmp_ref = expr->ref; tmp_ref; tmp_ref = tmp_ref->next)
! 		{
! 		  switch (tmp_ref->type)
! 		    {
! 		    case REF_COMPONENT:
! 		      field = tmp_ref->u.c.component->backend_decl;
! 		      gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
! 		      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
! 		      break;
! 
! 		    case REF_SUBSTRING:
! 		      gfc_init_se (&start, se);
! 		      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
! 		      gfc_conv_expr_type (&start, tmp_ref->u.ss.start, gfc_charlen_type_node);
! 		      gfc_add_block_to_block (&se->pre, &start.pre);
! 		      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
! 		      break;
! 
! 		    default:
! 		      break;
! 		    }
! 		}
! 	    }
! 
  	  offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
  	  gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
  	}
*************** structure_alloc_comps (gfc_symbol * der_
*** 5082,5088 ****
        /* Build the body of the loop.  */
        gfc_init_block (&loopbody);
  
!       vref = gfc_build_array_ref (var, index);
  
        if (purpose == COPY_ALLOC_COMP)
          {
--- 5132,5138 ----
        /* Build the body of the loop.  */
        gfc_init_block (&loopbody);
  
!       vref = gfc_build_array_ref (var, index, NULL);
  
        if (purpose == COPY_ALLOC_COMP)
          {
*************** structure_alloc_comps (gfc_symbol * der_
*** 5090,5096 ****
  	  gfc_add_expr_to_block (&fnblock, tmp);
  
  	  tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
! 	  dref = gfc_build_array_ref (tmp, index);
  	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
  	}
        else
--- 5140,5146 ----
  	  gfc_add_expr_to_block (&fnblock, tmp);
  
  	  tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
! 	  dref = gfc_build_array_ref (tmp, index, NULL);
  	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
  	}
        else
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 128135)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 206,212 ****
  	default:
  	  /* We should never got substring references here.  These will be
  	     broken down by the scalarizer.  */
! 	  gcc_unreachable ();
  	}
      }
  
--- 206,214 ----
  	default:
  	  /* We should never got substring references here.  These will be
  	     broken down by the scalarizer.  */
! 	  if (is_subref_array (e))
! 	    length = e->symtree->n.sym->ts.cl->backend_decl;
! 	  break;
  	}
      }
  
*************** gfc_conv_substring (gfc_se * se, gfc_ref
*** 270,276 ****
  	tmp = se->expr;
        else
  	tmp = build_fold_indirect_ref (se->expr);
!       tmp = gfc_build_array_ref (tmp, start.expr);
        se->expr = gfc_build_addr_expr (type, tmp);
      }
  
--- 272,278 ----
  	tmp = se->expr;
        else
  	tmp = build_fold_indirect_ref (se->expr);
!       tmp = gfc_build_array_ref (tmp, start.expr, NULL);
        se->expr = gfc_build_addr_expr (type, tmp);
      }
  
*************** gfc_apply_interface_mapping (gfc_interfa
*** 1782,1796 ****
    gfc_free_expr (expr);
  }
  
  /* Returns a reference to a temporary array into which a component of
     an actual argument derived type array is copied and then returned
!    after the function call.
!    TODO Get rid of this kludge, when array descriptors are capable of
!    handling arrays with a bigger stride in bytes than size.  */
! 
  void
! gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
! 		      int g77, sym_intent intent)
  {
    gfc_se lse;
    gfc_se rse;
--- 1784,1796 ----
    gfc_free_expr (expr);
  }
  
+ 
  /* Returns a reference to a temporary array into which a component of
     an actual argument derived type array is copied and then returned
!    after the function call.  */
  void
! gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
! 			   int g77, sym_intent intent)
  {
    gfc_se lse;
    gfc_se rse;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1962,1968 ****
  
    /* Now use the offset for the reference.  */
    tmp = build_fold_indirect_ref (info->data);
!   rse.expr = gfc_build_array_ref (tmp, tmp_index);
  
    if (expr->ts.type == BT_CHARACTER)
      rse.string_length = expr->ts.cl->backend_decl;
--- 1962,1968 ----
  
    /* Now use the offset for the reference.  */
    tmp = build_fold_indirect_ref (info->data);
!   rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
  
    if (expr->ts.type == BT_CHARACTER)
      rse.string_length = expr->ts.cl->backend_decl;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 2005,2032 ****
    return;
  }
  
- /* Is true if an array reference is followed by a component or substring
-    reference.  */
- 
- bool
- is_aliased_array (gfc_expr * e)
- {
-   gfc_ref * ref;
-   bool seen_array;
- 
-   seen_array = false;	
-   for (ref = e->ref; ref; ref = ref->next)
-     {
-       if (ref->type == REF_ARRAY
- 	    && ref->u.ar.type != AR_ELEMENT)
- 	seen_array = true;
- 
-       if (seen_array
- 	    && ref->type != REF_ARRAY)
- 	return seen_array;
-     }
-   return false;
- }
  
  /* Generate the code for argument list functions.  */
  
--- 2005,2010 ----
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2256,2267 ****
  	      f = f || !sym->attr.always_explicit;
  
  	      if (e->expr_type == EXPR_VARIABLE
! 		    && is_aliased_array (e))
  		/* The actual argument is a component reference to an
  		   array of derived types.  In this case, the argument
  		   is converted to a temporary, which is passed and then
  		   written back after the procedure call.  */
! 		gfc_conv_aliased_arg (&parmse, e, f,
  			fsym ? fsym->attr.intent : INTENT_INOUT);
  	      else
  	        gfc_conv_array_parameter (&parmse, e, argss, f);
--- 2234,2245 ----
  	      f = f || !sym->attr.always_explicit;
  
  	      if (e->expr_type == EXPR_VARIABLE
! 		    && is_subref_array (e))
  		/* The actual argument is a component reference to an
  		   array of derived types.  In this case, the argument
  		   is converted to a temporary, which is passed and then
  		   written back after the procedure call.  */
! 		gfc_conv_subref_array_arg (&parmse, e, f,
  			fsym ? fsym->attr.intent : INTENT_INOUT);
  	      else
  	        gfc_conv_array_parameter (&parmse, e, argss, f);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 3485,3490 ****
--- 3463,3486 ----
  	  /* Assign directly to the pointer's descriptor.  */
            lse.direct_byref = 1;
  	  gfc_conv_expr_descriptor (&lse, expr2, rss);
+ 	  if (is_subref_array (expr2))
+ 	    {
+ 	      tree edecl, etmp;
+ 	      if (expr2->ts.type == BT_CHARACTER)
+ 		{
+ 		  edecl = expr2->symtree->n.sym->ts.cl->backend_decl;
+ 		  etmp = fold_convert (gfc_array_index_type, edecl);
+ 		}
+ 	      else
+ 		{
+ 		  edecl = expr2->symtree->n.sym->backend_decl;
+ 		  etmp = fold_convert (gfc_array_index_type,
+ 		      size_in_bytes (gfc_get_element_type (TREE_TYPE (edecl))));
+ 		}
+   
+ 	      edecl = expr1->symtree->n.sym->backend_decl;
+ 	      gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(edecl), etmp);
+ 	    }
  	  break;
  
  	default:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 128135)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 578,584 ****
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
      optional:1, pointer:1, target:1, value:1, volatile_:1,
      dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
!     implied_index:1;
  
    ENUM_BITFIELD (save_state) save:2;
  
--- 578,584 ----
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
      optional:1, pointer:1, target:1, value:1, volatile_:1,
      dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
!     implied_index:1, subref_array_pointer:1;
  
    ENUM_BITFIELD (save_state) save:2;
  
*************** void gfc_free_actual_arglist (gfc_actual
*** 2166,2171 ****
--- 2166,2172 ----
  gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
  const char *gfc_extract_int (gfc_expr *, int *);
  gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+ bool is_subref_array (gfc_expr *);
  
  gfc_expr *gfc_build_conversion (gfc_expr *);
  void gfc_free_ref_list (gfc_ref *);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 128135)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_nested_forall_loop (forall_inf
*** 1650,1656 ****
            /* If a mask was specified make the assignment conditional.  */
            if (mask)
              {
!               tmp = gfc_build_array_ref (mask, maskindex);
                body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
              }
          }
--- 1650,1656 ----
            /* If a mask was specified make the assignment conditional.  */
            if (mask)
              {
!               tmp = gfc_build_array_ref (mask, maskindex, NULL);
                body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
              }
          }
*************** generate_loop_for_temp_to_lhs (gfc_expr 
*** 1729,1735 ****
        gfc_conv_expr (&lse, expr);
  
        /* Form the expression for the temporary.  */
!       tmp = gfc_build_array_ref (tmp1, count1);
  
        /* Use the scalar assignment as is.  */
        gfc_add_block_to_block (&block, &lse.pre);
--- 1729,1735 ----
        gfc_conv_expr (&lse, expr);
  
        /* Form the expression for the temporary.  */
!       tmp = gfc_build_array_ref (tmp1, count1, NULL);
  
        /* Use the scalar assignment as is.  */
        gfc_add_block_to_block (&block, &lse.pre);
*************** generate_loop_for_temp_to_lhs (gfc_expr 
*** 1770,1776 ****
  
        /* Form the expression of the temporary.  */
        if (lss != gfc_ss_terminator)
! 	rse.expr = gfc_build_array_ref (tmp1, count1);
        /* Translate expr.  */
        gfc_conv_expr (&lse, expr);
  
--- 1770,1776 ----
  
        /* Form the expression of the temporary.  */
        if (lss != gfc_ss_terminator)
! 	rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
        /* Translate expr.  */
        gfc_conv_expr (&lse, expr);
  
*************** generate_loop_for_temp_to_lhs (gfc_expr 
*** 1781,1787 ****
        /* Form the mask expression according to the mask tree list.  */
        if (wheremask)
  	{
! 	  wheremaskexpr = gfc_build_array_ref (wheremask, count3);
  	  if (invert)
  	    wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
  					 TREE_TYPE (wheremaskexpr),
--- 1781,1787 ----
        /* Form the mask expression according to the mask tree list.  */
        if (wheremask)
  	{
! 	  wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
  	  if (invert)
  	    wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
  					 TREE_TYPE (wheremaskexpr),
*************** generate_loop_for_rhs_to_temp (gfc_expr 
*** 1843,1849 ****
      {
        gfc_init_block (&body1);
        gfc_conv_expr (&rse, expr2);
!       lse.expr = gfc_build_array_ref (tmp1, count1);
      }
    else
      {
--- 1843,1849 ----
      {
        gfc_init_block (&body1);
        gfc_conv_expr (&rse, expr2);
!       lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
      }
    else
      {
*************** generate_loop_for_rhs_to_temp (gfc_expr 
*** 1867,1873 ****
        gfc_conv_expr (&rse, expr2);
  
        /* Form the expression of the temporary.  */
!       lse.expr = gfc_build_array_ref (tmp1, count1);
      }
  
    /* Use the scalar assignment.  */
--- 1867,1873 ----
        gfc_conv_expr (&rse, expr2);
  
        /* Form the expression of the temporary.  */
!       lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
      }
  
    /* Use the scalar assignment.  */
*************** generate_loop_for_rhs_to_temp (gfc_expr 
*** 1878,1884 ****
    /* Form the mask expression according to the mask tree list.  */
    if (wheremask)
      {
!       wheremaskexpr = gfc_build_array_ref (wheremask, count3);
        if (invert)
  	wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
  				     TREE_TYPE (wheremaskexpr),
--- 1878,1884 ----
    /* Form the mask expression according to the mask tree list.  */
    if (wheremask)
      {
!       wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
        if (invert)
  	wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
  				     TREE_TYPE (wheremaskexpr),
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2251,2257 ****
  					    inner_size, NULL, block, &ptemp1);
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
!       lse.expr = gfc_build_array_ref (tmp1, count);
        gfc_init_se (&rse, NULL);
        rse.want_pointer = 1;
        gfc_conv_expr (&rse, expr2);
--- 2251,2257 ----
  					    inner_size, NULL, block, &ptemp1);
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
!       lse.expr = gfc_build_array_ref (tmp1, count, NULL);
        gfc_init_se (&rse, NULL);
        rse.want_pointer = 1;
        gfc_conv_expr (&rse, expr2);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2278,2284 ****
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
        gfc_init_se (&rse, NULL);
!       rse.expr = gfc_build_array_ref (tmp1, count);
        lse.want_pointer = 1;
        gfc_conv_expr (&lse, expr1);
        gfc_add_block_to_block (&body, &lse.pre);
--- 2278,2284 ----
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
        gfc_init_se (&rse, NULL);
!       rse.expr = gfc_build_array_ref (tmp1, count, NULL);
        lse.want_pointer = 1;
        gfc_conv_expr (&lse, expr1);
        gfc_add_block_to_block (&body, &lse.pre);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2320,2326 ****
  					    inner_size, NULL, block, &ptemp1);
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
!       lse.expr = gfc_build_array_ref (tmp1, count);
        lse.direct_byref = 1;
        rss = gfc_walk_expr (expr2);
        gfc_conv_expr_descriptor (&lse, expr2, rss);
--- 2320,2326 ----
  					    inner_size, NULL, block, &ptemp1);
        gfc_start_block (&body);
        gfc_init_se (&lse, NULL);
!       lse.expr = gfc_build_array_ref (tmp1, count, NULL);
        lse.direct_byref = 1;
        rss = gfc_walk_expr (expr2);
        gfc_conv_expr_descriptor (&lse, expr2, rss);
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2343,2349 ****
        /* Reset count.  */
        gfc_add_modify_expr (block, count, gfc_index_zero_node);
  
!       parm = gfc_build_array_ref (tmp1, count);
        lss = gfc_walk_expr (expr1);
        gfc_init_se (&lse, NULL);
        gfc_conv_expr_descriptor (&lse, expr1, lss);
--- 2343,2349 ----
        /* Reset count.  */
        gfc_add_modify_expr (block, count, gfc_index_zero_node);
  
!       parm = gfc_build_array_ref (tmp1, count, NULL);
        lss = gfc_walk_expr (expr1);
        gfc_init_se (&lse, NULL);
        gfc_conv_expr_descriptor (&lse, expr1, lss);
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2596,2602 ****
        /* Store the mask.  */
        se.expr = convert (mask_type, se.expr);
  
!       tmp = gfc_build_array_ref (mask, maskindex);
        gfc_add_modify_expr (&body, tmp, se.expr);
  
        /* Advance to the next mask element.  */
--- 2596,2602 ----
        /* Store the mask.  */
        se.expr = convert (mask_type, se.expr);
  
!       tmp = gfc_build_array_ref (mask, maskindex, NULL);
        gfc_add_modify_expr (&body, tmp, se.expr);
  
        /* Advance to the next mask element.  */
*************** gfc_evaluate_where_mask (gfc_expr * me, 
*** 2795,2801 ****
  
    if (mask && (cmask || pmask))
      {
!       tmp = gfc_build_array_ref (mask, count);
        if (invert)
  	tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
        gfc_add_modify_expr (&body1, mtmp, tmp);
--- 2795,2801 ----
  
    if (mask && (cmask || pmask))
      {
!       tmp = gfc_build_array_ref (mask, count, NULL);
        if (invert)
  	tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
        gfc_add_modify_expr (&body1, mtmp, tmp);
*************** gfc_evaluate_where_mask (gfc_expr * me, 
*** 2803,2809 ****
  
    if (cmask)
      {
!       tmp1 = gfc_build_array_ref (cmask, count);
        tmp = cond;
        if (mask)
  	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
--- 2803,2809 ----
  
    if (cmask)
      {
!       tmp1 = gfc_build_array_ref (cmask, count, NULL);
        tmp = cond;
        if (mask)
  	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
*************** gfc_evaluate_where_mask (gfc_expr * me, 
*** 2812,2818 ****
  
    if (pmask)
      {
!       tmp1 = gfc_build_array_ref (pmask, count);
        tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
        if (mask)
  	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
--- 2812,2818 ----
  
    if (pmask)
      {
!       tmp1 = gfc_build_array_ref (pmask, count, NULL);
        tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
        if (mask)
  	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 2971,2977 ****
  
    /* Form the mask expression according to the mask.  */
    index = count1;
!   maskexpr = gfc_build_array_ref (mask, index);
    if (invert)
      maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
  
--- 2971,2977 ----
  
    /* Form the mask expression according to the mask.  */
    index = count1;
!   maskexpr = gfc_build_array_ref (mask, index, NULL);
    if (invert)
      maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
  
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 3028,3034 ****
  
            /* Form the mask expression according to the mask tree list.  */
            index = count2;
!           maskexpr = gfc_build_array_ref (mask, index);
  	  if (invert)
  	    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
  				    maskexpr);
--- 3028,3034 ----
  
            /* Form the mask expression according to the mask tree list.  */
            index = count2;
!           maskexpr = gfc_build_array_ref (mask, index, NULL);
  	  if (invert)
  	    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
  				    maskexpr);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 128135)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_is_constant_expr (gfc_expr *e)
*** 792,797 ****
--- 792,826 ----
  }
  
  
+ /* Is true if an array reference is followed by a component or substring
+    reference.  */
+ bool
+ is_subref_array (gfc_expr * e)
+ {
+   gfc_ref * ref;
+   bool seen_array;
+ 
+   if (e->expr_type != EXPR_VARIABLE)
+     return false;
+ 
+   if (e->symtree->n.sym->attr.subref_array_pointer)
+     return true;
+ 
+   seen_array = false;
+   for (ref = e->ref; ref; ref = ref->next)
+     {
+       if (ref->type == REF_ARRAY
+ 	    && ref->u.ar.type != AR_ELEMENT)
+ 	seen_array = true;
+ 
+       if (seen_array
+ 	    && ref->type != REF_ARRAY)
+ 	return seen_array;
+     }
+   return false;
+ }
+ 
+ 
  /* Try to collapse intrinsic expressions.  */
  
  static try
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 2802,2807 ****
--- 2831,2839 ----
        return FAILURE;
      }
  
+   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+ 
    attr = gfc_expr_attr (rvalue);
    if (!attr.target && !attr.pointer)
      {
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 128135)
--- gcc/fortran/trans.c	(working copy)
*************** gfc_build_addr_expr (tree type, tree t)
*** 309,317 ****
  /* Build an ARRAY_REF with its natural type.  */
  
  tree
! gfc_build_array_ref (tree base, tree offset)
  {
    tree type = TREE_TYPE (base);
    gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
    type = TREE_TYPE (type);
  
--- 309,319 ----
  /* Build an ARRAY_REF with its natural type.  */
  
  tree
! gfc_build_array_ref (tree base, tree offset, tree decl)
  {
    tree type = TREE_TYPE (base);
+   tree tmp;
+ 
    gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
    type = TREE_TYPE (type);
  
*************** gfc_build_array_ref (tree base, tree off
*** 321,327 ****
    /* Strip NON_LVALUE_EXPR nodes.  */
    STRIP_TYPE_NOPS (offset);
  
!   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
  }
  
  
--- 323,350 ----
    /* 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
! 		     || TREE_CODE (decl) == VAR_DECL
! 		     || TREE_CODE (decl) == PARM_DECL)
! 	&& GFC_DECL_SUBREF_ARRAY_P (decl)
! 	&& !integer_zerop (GFC_DECL_SPAN(decl)))
!     {
!       offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
! 			    offset, GFC_DECL_SPAN(decl));
!       tmp = gfc_build_addr_expr (pvoid_type_node, base);
!       tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
! 			 tmp, fold_convert (sizetype, offset));
!       tmp = fold_convert (build_pointer_type (type), tmp);
!       if (!TYPE_STRING_FLAG (type))
! 	tmp = build_fold_indirect_ref (tmp);
!       return tmp;
!     }
!   else
!     /* Otherwise use a straightforward array reference.  */
!     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
  }
  
  
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 128135)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_conv_operator_assign (gfc_se *,
*** 316,323 ****
  int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
  			    tree);
  
! void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
! bool is_aliased_array (gfc_expr *);
  
  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
  
--- 316,322 ----
  int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
  			    tree);
  
! void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
  
  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
  
*************** tree gfc_get_function_decl (gfc_symbol *
*** 379,385 ****
  tree gfc_build_addr_expr (tree, tree);
  
  /* Build an ARRAY_REF.  */
! tree gfc_build_array_ref (tree, tree);
  
  /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
  tree gfc_build_label_decl (tree);
--- 378,384 ----
  tree gfc_build_addr_expr (tree, tree);
  
  /* Build an ARRAY_REF.  */
! tree gfc_build_array_ref (tree, tree, tree);
  
  /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
  tree gfc_build_label_decl (tree);
*************** struct lang_decl		GTY(())
*** 593,603 ****
--- 592,604 ----
       address of target label.  */
    tree stringlen;
    tree addr;
+   tree span;
  };
  
  
  #define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
  #define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+ #define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
  #define GFC_DECL_SAVED_DESCRIPTOR(node) \
    (DECL_LANG_SPECIFIC(node)->saved_descriptor)
  #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
*************** struct lang_decl		GTY(())
*** 606,611 ****
--- 607,613 ----
  #define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
  #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
  #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
+ #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
  
  /* An array descriptor.  */
  #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 128135)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1016,1021 ****
--- 1016,1040 ----
  	  gcc_assert (!sym->value);
  	}
      }
+   else if (sym->attr.subref_array_pointer)
+     {
+       /* We need the span for these beasts.  */
+       gfc_allocate_lang_decl (decl);
+     }
+ 
+   if (sym->attr.subref_array_pointer)
+     {
+       tree span;
+       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
+       span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
+ 			 gfc_array_index_type);
+       gfc_finish_var_decl (span, sym);
+       TREE_STATIC (span) = 1;
+       DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+ 
+       GFC_DECL_SPAN (decl) = span;
+     }
+ 
    sym->backend_decl = decl;
  
    if (sym->attr.assign)
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 128135)
--- gcc/fortran/trans-io.c	(working copy)
*************** set_internal_unit (stmtblock_t * block, 
*** 724,734 ****
      {
        se.ss = gfc_walk_expr (e);
  
!       if (is_aliased_array (e))
  	{
  	  /* Use a temporary for components of arrays of derived types
  	     or substring array references.  */
! 	  gfc_conv_aliased_arg (&se, e, 0,
  		last_dt == READ ? INTENT_IN : INTENT_OUT);
  	  tmp = build_fold_indirect_ref (se.expr);
  	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
--- 724,734 ----
      {
        se.ss = gfc_walk_expr (e);
  
!       if (is_subref_array (e))
  	{
  	  /* Use a temporary for components of arrays of derived types
  	     or substring array references.  */
! 	  gfc_conv_subref_array_arg (&se, e, 0,
  		last_dt == READ ? INTENT_IN : INTENT_OUT);
  	  tmp = build_fold_indirect_ref (se.expr);
  	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
*************** nml_get_addr_expr (gfc_symbol * sym, gfc
*** 1330,1336 ****
       a RECORD_TYPE.  */
  
    if (array_flagged)
!     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
  
    /* Now build the address expression.  */
  
--- 1330,1336 ----
       a RECORD_TYPE.  */
  
    if (array_flagged)
!     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
  
    /* Now build the address expression.  */
  
*************** gfc_trans_transfer (gfc_code * code)
*** 1964,1970 ****
  	  gcc_assert (ref->type == REF_ARRAY);
  	}
  
!       if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
  	{
  	  /* Get the descriptor.  */
  	  gfc_conv_expr_descriptor (&se, expr, ss);
--- 1964,1972 ----
  	  gcc_assert (ref->type == REF_ARRAY);
  	}
  
!       if (expr->ts.type != BT_DERIVED
! 	    && ref && ref->next == NULL
! 	    && !is_subref_array (expr))
  	{
  	  /* Get the descriptor.  */
  	  gfc_conv_expr_descriptor (&se, expr, ss);
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/subref_array_pointer_1.f90	(revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ ! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+ ! to arrays with subreferences did not work.
+ !
+   type :: t
+     real :: r
+     integer :: i
+     character(3) :: chr
+   end type t
+   type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
+   character(4), target :: tar2(2) = (/"abcd","efgh"/)
+ 
+   integer, pointer :: ptr(:)
+   character(2), pointer :: ptr2(:)
+ 
+ !_______________component subreference___________
+   ptr => tar1%i
+   ptr = ptr + 1              ! check the scalarizer is OK
+ 
+   if (any (ptr .ne. (/3, 5/))) call abort ()
+   if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort ()
+   if (any (tar1%i .ne. (/3, 5/))) call abort ()
+ 
+ ! Make sure that the other components are not touched.
+   if (any (tar1%r .ne. (/1.0, 3.0/))) call abort ()
+   if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort ()
+ 
+ ! Check that the pointer is passed correctly as an actual argument.
+   call foo (ptr)
+   if (any (tar1%i .ne. (/2, 4/))) call abort ()
+ 
+ ! And that dummy pointers are OK too.
+   call bar (ptr)
+   if (any (tar1%i .ne. (/101, 103/))) call abort ()
+ 
+ !_______________substring subreference___________
+   ptr2 => tar2(:)(2:3)
+   ptr2 = ptr2(:)(2:2)//"z"   ! again, check the scalarizer
+ 
+   if (any (ptr2 .ne. (/"cz", "gz"/))) call abort ()
+   if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort ()
+   if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort ()
+ 
+ !_______________substring component subreference___________
+ !  ptr2 => tar1(:)%chr(1:2)  ! This does not work so far.
+ 
+ !_______________forall assignment___________
+   ptr2 => tar2(:)(1:2)
+   forall (i = 1:2) ptr2(i)(1:1) = "z"
+   if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort ()
+ 
+ contains
+   subroutine foo (arg)
+     integer :: arg(:)
+     arg = arg - 1
+   end subroutine
+   subroutine bar (arg)
+     integer, pointer :: arg(:)
+     arg = arg + 99
+   end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/function_kinds_1.f90
===================================================================

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]