This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC 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] PR42309 - Problem with a pointer array passed to a subroutine


This is another one of our serious bugs and yet another that can only
be properly fixed by array descriptor reform.  A dummy, pointer
argument is expected to have unity lbounds, with an appropriate
offset, and this patch makes it so.  The fix has the advantage of
fixing, if not a corner case, certainly something quite unusual;
therefore, the likelihood of regression is small..... on geological
timescales.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.4?

Paul

2010-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42309
	* trans-expr.c (gfc_conv_subref_array_arg): Add new argument
	'formal_ptr'. If this is true, give returned descriptor unity
	lbounds, in all dimensions, and the appropriate offset.
	(gfc_conv_procedure_call); If formal is a pointer, set the last
	argument of gfc_conv_subref_array_arg to true.
	* trans.h : Add last argument for gfc_conv_subref_array_arg.
	* trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
	new arg of gfc_conv_subref_array_arg to false.
	* trans-stmt.c (forall_make_variable_temp): The same.

2010-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42309
	* gfortran.dg/subref_array_pointer_4.f90 : New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 156460)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_apply_interface_mapping (gfc_interfa
*** 2294,2301 ****
     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;
--- 2294,2301 ----
     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, bool formal_ptr)
  {
    gfc_se lse;
    gfc_se rse;
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 2308,2313 ****
--- 2308,2314 ----
    tree tmp_index;
    tree tmp;
    tree base_type;
+   tree size;
    stmtblock_t body;
    int n;
  
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 2501,2506 ****
--- 2502,2543 ----
    if (expr->ts.type == BT_CHARACTER)
      parmse->string_length = expr->ts.u.cl->backend_decl;
  
+   /* Determine the offset for pointer formal arguments ans set the
+      lbounds to one.  */
+   if (formal_ptr)
+     {
+       size = gfc_index_one_node;
+       offset = gfc_index_zero_node;  
+       for (n = 0; n < info->dimen; n++)
+ 	{
+ 	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+ 						gfc_rank_cst[n]);
+ 	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+ 	  gfc_conv_descriptor_ubound_set (&parmse->pre,
+ 					  parmse->expr,
+ 					  gfc_rank_cst[n],
+ 					  tmp);
+ 	  gfc_conv_descriptor_lbound_set (&parmse->pre,
+ 					  parmse->expr,
+ 					  gfc_rank_cst[n],
+ 					  gfc_index_one_node);
+ 	  size = gfc_evaluate_now (size, &parmse->pre);
+ 	  offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ 				offset, size);
+ 	  offset = gfc_evaluate_now (offset, &parmse->pre);
+ 	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ 			     rse.loop->to[n], rse.loop->from[n]);
+ 	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ 			     tmp, gfc_index_one_node);
+ 	  size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ 			      size, tmp);
+ 	}
+ 
+       gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+ 				      offset);
+     }
+ 
    /* We want either the address for the data or the address of the descriptor,
       depending on the mode of passing array arguments.  */
    if (g77)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3005,3011 ****
  		   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, fsym,
  					  sym->name, NULL);
--- 3042,3049 ----
  		   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,
! 				fsym && fsym->attr.pointer);
  	      else
  	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
  					  sym->name, NULL);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 156460)
--- gcc/fortran/trans.h	(working copy)
*************** int gfc_is_intrinsic_libcall (gfc_expr *
*** 315,321 ****
  int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
  			    gfc_expr *, 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 */
  
--- 316,322 ----
  int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
  			    gfc_expr *, tree);
  
! void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
  
  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
  
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 156460)
--- gcc/fortran/trans-io.c	(working copy)
*************** set_internal_unit (stmtblock_t * block, 
*** 741,747 ****
  	  /* 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_loc (input_location,
  					 se.expr);
  	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
--- 741,747 ----
  	  /* 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, false);
  	  tmp = build_fold_indirect_ref_loc (input_location,
  					 se.expr);
  	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
*************** gfc_trans_transfer (gfc_code * code)
*** 2211,2217 ****
  	  if (seen_vector && last_dt == READ)
  	    {
  	      /* Create a temp, read to that and copy it back.  */
! 	      gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
  	      tmp =  se.expr;
  	    }
  	  else
--- 2211,2217 ----
  	  if (seen_vector && last_dt == READ)
  	    {
  	      /* Create a temp, read to that and copy it back.  */
! 	      gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
  	      tmp =  se.expr;
  	    }
  	  else
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 156460)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** forall_make_variable_temp (gfc_code *c, 
*** 1800,1806 ****
    if (old_sym->attr.dimension)
      {
        gfc_init_se (&tse, NULL);
!       gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
        gfc_add_block_to_block (pre, &tse.pre);
        gfc_add_block_to_block (post, &tse.post);
        tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
--- 1800,1806 ----
    if (old_sym->attr.dimension)
      {
        gfc_init_se (&tse, NULL);
!       gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
        gfc_add_block_to_block (pre, &tse.pre);
        gfc_add_block_to_block (post, &tse.post);
        tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90	(revision 0)
***************
*** 0 ****
--- 1,27 ----
+ ! { dg-do run }
+ ! Tests the fix for PR42309, in which the indexing of 'Q'
+ ! was off by one.
+ !
+ ! Contributed by Gilbert Scott <gilbert.scott@easynet.co.uk>
+ !
+ PROGRAM X
+   TYPE T
+     INTEGER :: I
+     REAL :: X
+   END TYPE T
+   TYPE(T), TARGET :: T1(0:3)
+   INTEGER, POINTER :: P(:)
+   REAL :: SOURCE(4) = [10., 20., 30., 40.]
+ 
+   T1%I = [1, 2, 3, 4]
+   T1%X = SOURCE
+   P => T1%I
+   CALL Z(P)
+   IF (ANY (T1%I .NE. [999, 2, 999, 4])) CALL ABORT
+   IF (ANY (T1%X .NE. SOURCE)) CALL ABORT
+ CONTAINS
+   SUBROUTINE Z(Q)
+     INTEGER, POINTER :: Q(:)
+     Q(1:3:2) = 999
+   END SUBROUTINE Z
+ END PROGRAM X

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