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]

Re: [Patch, fortran] PR31217 - ICE using FORALL on character substrings


FX Coudert wrote:
>> Looking at the patch, it think it is OK. (Though, I would not mind if
>> someone else could glance over the patch as it is rather large.)
> I haven't gone into the details, but it looks OK to me too, so let's
> get it committed and see what it breaks :)

Attached is the new version of Paul's patch, which he send me and
Dominique this morning in a private mail. (The patch contained also a
fix of PR33897, which I intent to extract and to post later.)

The attached patch is essentially the same as the one posted on 26
October, http://gcc.gnu.org/ml/fortran/2007-10/msg00341.html, except for
a fix in trans-stmt.c (see below). The previous patch plus the half of
the fix were approved yesterday by me, and FX also glanced over it.

(Build and regression tested on x86-64-linux.)
I intent to commit it in 24h unless someone approves it earlier - or has
objections.

Tobias


Interdiff for trans-stmt.c between Paul's 26 October patch and his new
patch/the attached patch:

diff -u gcc/fortran/trans-stmt.c gcc/fortran/trans-stmt.c
--- gcc/fortran/trans-stmt.c    (working copy)
+++ gcc/fortran/trans-stmt.c    (working copy)
@@ -1663,9 +1663,12 @@
      the variable will not suffice for derived types with
      pointer components.  We therefore leave these to their
      own devices.  */
+  if (lsym->ts.type == BT_DERIVED
+       && lsym->ts.derived->attr.pointer_comp)
+    return need_temp;
+
   new_symtree = NULL;
-  if ((find_forall_index (c->expr, lsym, 2) == SUCCESS)
-        && !lsym->attr.pointer_comp)
+  if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
     {
       forall_make_variable_temp (c, pre, post);
       need_temp = 0;


The patch contained, additionally, changes to decl.c, parse.c and
contained_3.f90 for PR33897 and the following patch which seems to be
unrelated to either PR. (These changes are not in the attached patch.)

--- gcc/fortran/trans-intrinsic.c       (revision 129504)
+++ gcc/fortran/trans-intrinsic.c       (working copy)
@@ -3171,8 +3171,6 @@ gfc_conv_intrinsic_array_transfer (gfc_s
     {
       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
                         tmp, dest_word_len);
-      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
-                        tmp, source_bytes);
     }
   else
     tmp = source_bytes;
@@ -3229,7 +3227,7 @@ gfc_conv_intrinsic_array_transfer (gfc_s
                         3,
                         tmp,
                         fold_convert (pvoid_type_node, source),
-                        size_bytes);
+                        source_bytes);
   gfc_add_expr_to_block (&se->pre, tmp);

   se->expr = info->descriptor;

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

   PR fortran/31217
   PR fortran/33811
   PR fortran/33686
   * trans-array.c (gfc_conv_loop_setup): Send a complete type to
   gfc_trans_create_temp_array if the temporary is character.
   * trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
   allocate_temp_for_forall_nest.
   (forall_replace): New function.
   (forall_replace_symtree): New function.
   (forall_restore): New function.
   (forall_restore_symtree): New function.
   (forall_make_variable_temp): New function.
   (check_forall_dependencies): New function.
   (cleanup_forall_symtrees): New function.
   gfc_trans_forall_1): Add and initialize pre and post blocks.
   Call check_forall_dependencies to check for all dependencies
   and either trigger second forall block to copy temporary or
   copy lval, outside the forall construct and replace all
   dependent references. After assignment clean-up and coalesce
   the blocks at the end of the function.
   * gfortran.h : Add prototypes for gfc_traverse_expr and
   find_forall_index.
   expr.c (gfc_traverse_expr): New function to traverse expression
   and visit all subexpressions, under control of a logical flag,
   a symbol and an integer pointer. The slave function is caller
   defined and is only called on EXPR_VARIABLE.
   (expr_set_symbols_referenced): Called by above to set symbols
   referenced.
   (gfc_expr_set_symbols_referenced): Rework of this function to
   use two new functions above.
   * resolve.c (find_forall_index): Rework with gfc_traverse_expr,
   using forall_index.
   (forall_index): New function used by previous.
   * dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
   all references, not just REF_ARRAY.
   (gfc_dep_resolver): Correct the logic for substrings so that
   overlapping arrays are handled correctly.

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

   PR fortran/31217
   PR fortran/33811
   * gfortran.dg/forall_12.f90: New test.


   PR fortran/33686
   * gfortran.dg/forall_13.f90: New test.

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 129505)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 3376,3381 ****
--- 3376,3388 ----
    if (loop->temp_ss != NULL)
      {
        gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
+ 
+       /* Make absolutely sure that this is a complete type.  */
+       if (loop->temp_ss->string_length)
+ 	loop->temp_ss->data.temp.type
+ 		= gfc_get_character_type_len (gfc_default_character_kind,
+ 					      loop->temp_ss->string_length);
+ 
        tmp = loop->temp_ss->data.temp.type;
        len = loop->temp_ss->string_length;
        n = loop->temp_ss->data.temp.dimen;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 129504)
--- gcc/fortran/gfortran.h	(working copy)
*************** try gfc_check_assign_symbol (gfc_symbol 
*** 2233,2238 ****
--- 2233,2241 ----
  gfc_expr *gfc_default_initializer (gfc_typespec *);
  gfc_expr *gfc_get_variable_expr (gfc_symtree *);
  
+ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
+ 			bool (*)(gfc_expr *, gfc_symbol *, int*),
+ 			int);
  void gfc_expr_set_symbols_referenced (gfc_expr *);
  
  /* st.c */
*************** int gfc_impure_variable (gfc_symbol *);
*** 2252,2257 ****
--- 2255,2261 ----
  int gfc_pure (gfc_symbol *);
  int gfc_elemental (gfc_symbol *);
  try gfc_resolve_iterator (gfc_iterator *, bool);
+ try find_forall_index (gfc_expr *, gfc_symbol *, int);
  try gfc_resolve_index (gfc_expr *, int);
  try gfc_resolve_dim_arg (gfc_expr *);
  int gfc_is_formal_arg (void);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 129504)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_select (gfc_code * code)
*** 1510,1515 ****
--- 1510,1714 ----
  }
  
  
+ /* Traversal function to substitute a replacement symtree if the symbol
+    in the expression is the same as that passed.  f == 2 signals that
+    that variable itself is not to be checked - only the references.
+    This group of functions is used when the variable expression in a
+    FORALL assignment has internal references.  For example:
+ 		FORALL (i = 1:4) p(p(i)) = i
+    The only recourse here is to store a copy of 'p' for the index
+    expression.  */
+ 
+ static gfc_symtree *new_symtree;
+ static gfc_symtree *old_symtree;
+ 
+ static bool
+ forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
+ {
+   gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ 
+   if (*f == 2)
+     *f = 1;
+   else if (expr->symtree->n.sym == sym)
+     expr->symtree = new_symtree;
+ 
+   return false;
+ }
+ 
+ static void
+ forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
+ {
+   gfc_traverse_expr (e, sym, forall_replace, f);
+ }
+ 
+ static bool
+ forall_restore (gfc_expr *expr,
+ 		gfc_symbol *sym ATTRIBUTE_UNUSED,
+ 		int *f ATTRIBUTE_UNUSED)
+ {
+   gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ 
+   if (expr->symtree == new_symtree)
+     expr->symtree = old_symtree;
+ 
+   return false;
+ }
+ 
+ static void
+ forall_restore_symtree (gfc_expr *e)
+ {
+   gfc_traverse_expr (e, NULL, forall_restore, 0);
+ }
+ 
+ static void
+ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+ {
+   gfc_se tse;
+   gfc_se rse;
+   gfc_expr *e;
+   gfc_symbol *new_sym;
+   gfc_symbol *old_sym;
+   gfc_symtree *root;
+   tree tmp;
+ 
+   /* Build a copy of the lvalue.  */
+   old_symtree = c->expr->symtree;
+   old_sym = old_symtree->n.sym;
+   e = gfc_lval_expr_from_sym (old_sym);
+   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 (tse.expr);
+ 
+       if (e->ts.type != BT_CHARACTER)
+ 	{
+ 	  /* Use the variable offset for the temporary.  */
+ 	  tmp = gfc_conv_descriptor_offset (tse.expr);
+ 	  gfc_add_modify_expr (pre, tmp,
+ 		gfc_conv_array_offset (old_sym->backend_decl));
+ 	}
+     }
+   else
+     {
+       gfc_init_se (&tse, NULL);
+       gfc_init_se (&rse, NULL);
+       gfc_conv_expr (&rse, e);
+       if (e->ts.type == BT_CHARACTER)
+ 	{
+ 	  tse.string_length = rse.string_length;
+ 	  tmp = gfc_get_character_type_len (gfc_default_character_kind,
+ 					    tse.string_length);
+ 	  tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
+ 					  rse.string_length);
+ 	  gfc_add_block_to_block (pre, &tse.pre);
+ 	  gfc_add_block_to_block (post, &tse.post);
+ 	}
+       else
+ 	{
+ 	  tmp = gfc_typenode_for_spec (&e->ts);
+ 	  tse.expr = gfc_create_var (tmp, "temp");
+ 	}
+ 
+       tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
+ 				     e->expr_type == EXPR_VARIABLE);
+       gfc_add_expr_to_block (pre, tmp);
+     }
+   gfc_free_expr (e);
+ 
+   /* Create a new symbol to represent the lvalue.  */
+   new_sym = gfc_new_symbol (old_sym->name, NULL);
+   new_sym->ts = old_sym->ts;
+   new_sym->attr.referenced = 1;
+   new_sym->attr.dimension = old_sym->attr.dimension;
+   new_sym->attr.flavor = old_sym->attr.flavor;
+ 
+   /* Use the temporary as the backend_decl.  */
+   new_sym->backend_decl = tse.expr;
+ 
+   /* Create a fake symtree for it.  */
+   root = NULL;
+   new_symtree = gfc_new_symtree (&root, old_sym->name);
+   new_symtree->n.sym = new_sym;
+   gcc_assert (new_symtree == root);
+ 
+   /* Go through the expression reference replacing the old_symtree
+      with the new.  */
+   forall_replace_symtree (c->expr, old_sym, 2);
+ 
+   /* Now we have made this temporary, we might as well use it for
+   the right hand side.  */
+   forall_replace_symtree (c->expr2, old_sym, 1);
+ }
+ 
+ 
+ /* Handles dependencies in forall assignments.  */
+ static int
+ check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
+ {
+   gfc_ref *lref;
+   gfc_ref *rref;
+   int need_temp;
+   gfc_symbol *lsym;
+ 
+   lsym = c->expr->symtree->n.sym;
+   need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
+ 
+   /* Now check for dependencies within the 'variable'
+      expression itself.  These are treated by making a complete
+      copy of variable and changing all the references to it
+      point to the copy instead.  Note that the shallow copy of
+      the variable will not suffice for derived types with
+      pointer components.  We therefore leave these to their
+      own devices.  */
+   if (lsym->ts.type == BT_DERIVED
+ 	&& lsym->ts.derived->attr.pointer_comp)
+     return need_temp;
+ 
+   new_symtree = NULL;
+   if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
+     {
+       forall_make_variable_temp (c, pre, post);
+       need_temp = 0;
+     }
+ 
+   /* Substrings with dependencies are treated in the same
+      way.  */
+   if (c->expr->ts.type == BT_CHARACTER
+ 	&& c->expr->ref
+ 	&& c->expr2->expr_type == EXPR_VARIABLE
+ 	&& lsym == c->expr2->symtree->n.sym)
+     {
+       for (lref = c->expr->ref; lref; lref = lref->next)
+ 	if (lref->type == REF_SUBSTRING)
+ 	  break;
+       for (rref = c->expr2->ref; rref; rref = rref->next)
+ 	if (rref->type == REF_SUBSTRING)
+ 	  break;
+ 
+       if (rref && lref
+ 	    && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
+ 	{
+ 	  forall_make_variable_temp (c, pre, post);
+ 	  need_temp = 0;
+ 	}
+     }
+   return need_temp;
+ }
+ 
+ 
+ static void
+ cleanup_forall_symtrees (gfc_code *c)
+ {
+   forall_restore_symtree (c->expr);
+   forall_restore_symtree (c->expr2);
+   gfc_free (new_symtree->n.sym);
+   gfc_free (new_symtree);
+ }
+ 
+ 
  /* Generate the loops for a FORALL block, specified by FORALL_TMP.  BODY
     is the contents of the FORALL block/stmt to be iterated.  MASK_FLAG
     indicates whether we should generate code to test the FORALLs mask
*************** gfc_trans_assign_need_temp (gfc_expr * e
*** 2172,2178 ****
  					&lss, &rss);
  
    /* The type of LHS. Used in function allocate_temp_for_forall_nest */
!   type = gfc_typenode_for_spec (&expr1->ts);
  
    /* Allocate temporary for nested forall construct according to the
       information in nested_forall_info and inner_size.  */
--- 2371,2390 ----
  					&lss, &rss);
  
    /* The type of LHS. Used in function allocate_temp_for_forall_nest */
!   if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
!     {
!       if (!expr1->ts.cl->backend_decl)
! 	{
! 	  gfc_se tse;
! 	  gfc_init_se (&tse, NULL);
! 	  gfc_conv_expr (&tse, expr1->ts.cl->length);
! 	  expr1->ts.cl->backend_decl = tse.expr;
! 	}
!       type = gfc_get_character_type_len (gfc_default_character_kind,
! 				         expr1->ts.cl->backend_decl);
!     }
!   else
!     type = gfc_typenode_for_spec (&expr1->ts);
  
    /* Allocate temporary for nested forall construct according to the
       information in nested_forall_info and inner_size.  */
*************** gfc_trans_pointer_assign_need_temp (gfc_
*** 2412,2417 ****
--- 2624,2631 ----
  static tree
  gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
  {
+   stmtblock_t pre;
+   stmtblock_t post;
    stmtblock_t block;
    stmtblock_t body;
    tree *var;
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2459,2465 ****
    /* Allocate the space for info.  */
    info = (forall_info *) gfc_getmem (sizeof (forall_info));
  
!   gfc_start_block (&block);
  
    n = 0;
    for (fa = code->ext.forall_iterator; fa; fa = fa->next)
--- 2673,2681 ----
    /* Allocate the space for info.  */
    info = (forall_info *) gfc_getmem (sizeof (forall_info));
  
!   gfc_start_block (&pre);
!   gfc_init_block (&post);
!   gfc_init_block (&block);
  
    n = 0;
    for (fa = code->ext.forall_iterator; fa; fa = fa->next)
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2619,2626 ****
        switch (c->op)
  	{
  	case EXEC_ASSIGN:
!           /* A scalar or array assignment.  */
! 	  need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
            /* Temporaries due to array assignment data dependencies introduce
               no end of problems.  */
  	  if (need_temp)
--- 2835,2845 ----
        switch (c->op)
  	{
  	case EXEC_ASSIGN:
!           /* A scalar or array assignment.  DO the simple check for
! 	     lhs to rhs dependencies.  These make a temporary for the
! 	     rhs and form a second forall block to copy to variable.  */
! 	  need_temp = check_forall_dependencies(c, &pre, &post);
! 
            /* Temporaries due to array assignment data dependencies introduce
               no end of problems.  */
  	  if (need_temp)
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2637,2642 ****
--- 2856,2866 ----
                gfc_add_expr_to_block (&block, tmp);
              }
  
+ 	  /* Cleanup any temporary symtrees that have been made to deal
+ 	     with dependencies.  */
+ 	  if (new_symtree)
+ 	    cleanup_forall_symtrees (c);
+ 
  	  break;
  
          case EXEC_WHERE:
*************** gfc_trans_forall_1 (gfc_code * code, for
*** 2706,2712 ****
    if (maskindex)
      pushdecl (maskindex);
  
!   return gfc_finish_block (&block);
  }
  
  
--- 2930,2939 ----
    if (maskindex)
      pushdecl (maskindex);
  
!   gfc_add_block_to_block (&pre, &block);
!   gfc_add_block_to_block (&pre, &post);
! 
!   return gfc_finish_block (&pre);
  }
  
  
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 129504)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_get_variable_expr (gfc_symtree *var)
*** 2998,3029 ****
  }
  
  
! /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
  
! void
! gfc_expr_set_symbols_referenced (gfc_expr *expr)
  {
!   gfc_actual_arglist *arg;
!   gfc_constructor *c;
    gfc_ref *ref;
    int i;
  
!   if (!expr) return;
  
    switch (expr->expr_type)
      {
!     case EXPR_OP:
!       gfc_expr_set_symbols_referenced (expr->value.op.op1);
!       gfc_expr_set_symbols_referenced (expr->value.op.op2);
!       break;
  
!     case EXPR_FUNCTION:
!       for (arg = expr->value.function.actual; arg; arg = arg->next)
! 	gfc_expr_set_symbols_referenced (arg->expr);
!       break;
  
!     case EXPR_VARIABLE:
!       gfc_set_sym_referenced (expr->symtree->n.sym);
        break;
  
      case EXPR_CONSTANT:
--- 2998,3033 ----
  }
  
  
! /* General expression traversal function.  */
  
! bool
! gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
! 		   bool (*func)(gfc_expr *, gfc_symbol *, int*),
! 		   int f)
  {
!   gfc_array_ref ar;
    gfc_ref *ref;
+   gfc_actual_arglist *args;
+   gfc_constructor *c;
    int i;
  
!   if (!expr)
!     return false;
  
    switch (expr->expr_type)
      {
!     case EXPR_VARIABLE:
!       gcc_assert (expr->symtree->n.sym);
  
!       if ((*func) (expr, sym, &f))
! 	return true;
  
!     case EXPR_FUNCTION:
!       for (args = expr->value.function.actual; args; args = args->next)
! 	{
! 	  if (gfc_traverse_expr (args->expr, sym, func, f))
! 	    return true;
! 	}
        break;
  
      case EXPR_CONSTANT:
*************** gfc_expr_set_symbols_referenced (gfc_exp
*** 3037,3069 ****
  	gfc_expr_set_symbols_referenced (c->expr);
        break;
  
      default:
        gcc_unreachable ();
        break;
      }
  
!     for (ref = expr->ref; ref; ref = ref->next)
        switch (ref->type)
  	{
! 	case REF_ARRAY:
! 	  for (i = 0; i < ref->u.ar.dimen; i++)
  	    {
! 	      gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
! 	      gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
! 	      gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
  	    }
  	  break;
! 	   
! 	case REF_COMPONENT:
! 	  break;
! 	   
  	case REF_SUBSTRING:
! 	  gfc_expr_set_symbols_referenced (ref->u.ss.start);
! 	  gfc_expr_set_symbols_referenced (ref->u.ss.end);
  	  break;
! 	   
  	default:
  	  gcc_unreachable ();
- 	  break;
  	}
  }
--- 3041,3107 ----
  	gfc_expr_set_symbols_referenced (c->expr);
        break;
  
+     case EXPR_OP:
+       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
+ 	return true;
+       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
+ 	return true;
+       break;
+ 
      default:
        gcc_unreachable ();
        break;
      }
  
!   ref = expr->ref;
!   while (ref != NULL)
!     {
        switch (ref->type)
  	{
! 	case  REF_ARRAY:
! 	  ar = ref->u.ar;
! 	  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
  	    {
! 	      if (gfc_traverse_expr (ar.start[i], sym, func, f))
! 		return true;
! 	      if (gfc_traverse_expr (ar.end[i], sym, func, f))
! 		return true;
! 	      if (gfc_traverse_expr (ar.stride[i], sym, func, f))
! 		return true;
  	    }
  	  break;
! 
  	case REF_SUBSTRING:
! 	  if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
! 	    return true;
! 	  if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
! 	    return true;
  	  break;
! 
! 	  case REF_COMPONENT:
! 	    break;
! 
  	default:
  	  gcc_unreachable ();
  	}
+       ref = ref->next;
+     }
+   return false;
+ }
+ 
+ /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+ 
+ static bool
+ expr_set_symbols_referenced (gfc_expr *expr,
+ 			     gfc_symbol *sym ATTRIBUTE_UNUSED,
+ 			     int *f ATTRIBUTE_UNUSED)
+ {
+   gfc_set_sym_referenced (expr->symtree->n.sym);
+   return false;
+ }
+ 
+ void
+ gfc_expr_set_symbols_referenced (gfc_expr *expr)
+ {
+   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
  }
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 129504)
--- gcc/fortran/resolve.c	(working copy)
*************** gfc_resolve_iterator (gfc_iterator *iter
*** 4322,4452 ****
  }
  
  
! /* Check whether the FORALL index appears in the expression or not.
!    Returns SUCCESS if SYM is found in EXPR.  */
  
! static try
! find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
  {
!   gfc_array_ref ar;
!   gfc_ref *tmp;
!   gfc_actual_arglist *args;
!   int i;
! 
!   if (!expr)
!     return FAILURE;
  
!   switch (expr->expr_type)
      {
!     case EXPR_VARIABLE:
!       gcc_assert (expr->symtree->n.sym);
! 
!       /* A scalar assignment  */
!       if (!expr->ref)
! 	{
! 	  if (expr->symtree->n.sym == symbol)
! 	    return SUCCESS;
! 	  else
! 	    return FAILURE;
! 	}
! 
!       /* the expr is array ref, substring or struct component.  */
!       tmp = expr->ref;
!       while (tmp != NULL)
! 	{
! 	  switch (tmp->type)
! 	    {
! 	    case  REF_ARRAY:
! 	      /* Check if the symbol appears in the array subscript.  */
! 	      ar = tmp->u.ar;
! 	      for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
! 		{
! 		  if (ar.start[i])
! 		    if (find_forall_index (ar.start[i], symbol) == SUCCESS)
! 		      return SUCCESS;
! 
! 		  if (ar.end[i])
! 		    if (find_forall_index (ar.end[i], symbol) == SUCCESS)
! 		      return SUCCESS;
! 
! 		  if (ar.stride[i])
! 		    if (find_forall_index (ar.stride[i], symbol) == SUCCESS)
! 		      return SUCCESS;
! 		}  /* end for  */
! 	      break;
! 
! 	    case REF_SUBSTRING:
! 	      if (expr->symtree->n.sym == symbol)
! 		return SUCCESS;
! 	      tmp = expr->ref;
! 	      /* Check if the symbol appears in the substring section.  */
! 	      if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
! 		return SUCCESS;
! 	      if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
! 		return SUCCESS;
! 	      break;
! 
! 	    case REF_COMPONENT:
! 	      break;
! 
! 	    default:
! 	      gfc_error("expression reference type error at %L", &expr->where);
! 	    }
! 	  tmp = tmp->next;
! 	}
!       break;
! 
!     /* If the expression is a function call, then check if the symbol
!        appears in the actual arglist of the function.  */
!     case EXPR_FUNCTION:
!       for (args = expr->value.function.actual; args; args = args->next)
! 	{
! 	  if (find_forall_index(args->expr,symbol) == SUCCESS)
! 	    return SUCCESS;
! 	}
!       break;
! 
!     /* It seems not to happen.  */
!     case EXPR_SUBSTRING:
!       if (expr->ref)
! 	{
! 	  tmp = expr->ref;
! 	  gcc_assert (expr->ref->type == REF_SUBSTRING);
! 	  if (find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
! 	    return SUCCESS;
! 	  if (find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
! 	    return SUCCESS;
! 	}
!       break;
! 
!     /* It seems not to happen.  */
!     case EXPR_STRUCTURE:
!     case EXPR_ARRAY:
!       gfc_error ("Unsupported statement while finding forall index in "
! 		 "expression");
!       break;
  
!     case EXPR_OP:
!       /* Find the FORALL index in the first operand.  */
!       if (expr->value.op.op1)
! 	{
! 	  if (find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
! 	    return SUCCESS;
! 	}
  
-       /* Find the FORALL index in the second operand.  */
-       if (expr->value.op.op2)
- 	{
- 	  if (find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
- 	    return SUCCESS;
- 	}
-       break;
  
!     default:
!       break;
!     }
  
!   return FAILURE;
  }
  
  
--- 4322,4360 ----
  }
  
  
! /* Traversal function for find_forall_index.  f == 2 signals that
!    that variable itself is not to be checked - only the references.  */
  
! static bool
! forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
  {
!   gcc_assert (expr->expr_type == EXPR_VARIABLE);
  
!   /* A scalar assignment  */
!   if (!expr->ref || *f == 1)
      {
!       if (expr->symtree->n.sym == sym)
! 	return true;
!       else
! 	return false;
!     }
  
!   if (*f == 2)
!     *f = 1;
!   return false;
! }
  
  
! /* Check whether the FORALL index appears in the expression or not.
!    Returns SUCCESS if SYM is found in EXPR.  */
  
! try
! find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
! {
!   if (gfc_traverse_expr (expr, sym, forall_index, f))
!     return SUCCESS;
!   else
!     return FAILURE;
  }
  
  
*************** resolve_forall_iterators (gfc_forall_ite
*** 4502,4512 ****
      for (iter2 = iter; iter2; iter2 = iter2->next)
        {
  	if (find_forall_index (iter2->start,
! 			       iter->var->symtree->n.sym) == SUCCESS
  	    || find_forall_index (iter2->end,
! 				  iter->var->symtree->n.sym) == SUCCESS
  	    || find_forall_index (iter2->stride,
! 				  iter->var->symtree->n.sym) == SUCCESS)
  	  gfc_error ("FORALL index '%s' may not appear in triplet "
  		     "specification at %L", iter->var->symtree->name,
  		     &iter2->start->where);
--- 4410,4420 ----
      for (iter2 = iter; iter2; iter2 = iter2->next)
        {
  	if (find_forall_index (iter2->start,
! 			       iter->var->symtree->n.sym, 0) == SUCCESS
  	    || find_forall_index (iter2->end,
! 				  iter->var->symtree->n.sym, 0) == SUCCESS
  	    || find_forall_index (iter2->stride,
! 				  iter->var->symtree->n.sym, 0) == SUCCESS)
  	  gfc_error ("FORALL index '%s' may not appear in triplet "
  		     "specification at %L", iter->var->symtree->name,
  		     &iter2->start->where);
*************** gfc_resolve_assign_in_forall (gfc_code *
*** 5726,5732 ****
  	  /* If one of the FORALL index variables doesn't appear in the
  	     assignment target, then there will be a many-to-one
  	     assignment.  */
! 	  if (find_forall_index (code->expr, forall_index) == FAILURE)
  	    gfc_error ("The FORALL with index '%s' cause more than one "
  		       "assignment to this object at %L",
  		       var_expr[n]->symtree->name, &code->expr->where);
--- 5634,5640 ----
  	  /* If one of the FORALL index variables doesn't appear in the
  	     assignment target, then there will be a many-to-one
  	     assignment.  */
! 	  if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
  	    gfc_error ("The FORALL with index '%s' cause more than one "
  		       "assignment to this object at %L",
  		       var_expr[n]->symtree->name, &code->expr->where);
Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c	(revision 129504)
--- gcc/fortran/dependency.c	(working copy)
*************** gfc_check_dependency (gfc_expr *expr1, g
*** 657,664 ****
  
        /* Identical and disjoint ranges return 0,
  	 overlapping ranges return 1.  */
!       /* Return zero if we refer to the same full arrays.  */
!       if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
  	return gfc_dep_resolver (expr1->ref, expr2->ref);
  
        return 1;
--- 657,663 ----
  
        /* Identical and disjoint ranges return 0,
  	 overlapping ranges return 1.  */
!       if (expr1->ref && expr2->ref)
  	return gfc_dep_resolver (expr1->ref, expr2->ref);
  
        return 1;
*************** gfc_dep_resolver (gfc_ref *lref, gfc_ref
*** 1197,1204 ****
  	  break;
  	  
  	case REF_SUBSTRING:
! 	  /* Substring overlaps are handled by the string assignment code.  */
! 	  return 0;
  	
  	case REF_ARRAY:
  	  if (lref->u.ar.dimen != rref->u.ar.dimen)
--- 1196,1204 ----
  	  break;
  	  
  	case REF_SUBSTRING:
! 	  /* Substring overlaps are handled by the string assignment code
! 	     if there is not an underlying dependency.  */
! 	  return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
  	
  	case REF_ARRAY:
  	  if (lref->u.ar.dimen != rref->u.ar.dimen)
Index: gcc/testsuite/gfortran.dg/forall_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_12.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/forall_12.f90	(revision 0)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ ! Tests the fix for PR31217 and PR33811 , in which dependencies were not
+ ! correctly handled for the assignments below and, when this was fixed,
+ ! the last two ICEd on trying to create the temorary.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ !              Dominique d'Humieres <dominiq@lps.ens.fr>
+ !                   and Paul Thomas <pault@gcc.gnu.org>
+ !
+   character(len=1) :: a = "1"
+   character(len=1) :: b(4) = (/"1","2","3","4"/), c(4)
+   c = b
+   forall(i=1:1) a(i:i) = a(i:i)         ! This was the original PR31217
+   forall(i=1:1) b(i:i) = b(i:i)         ! The rest were found to be broken
+   forall(i=1:1) b(:)(i:i) = b(:)(i:i)
+   forall(i=1:1) b(1:3)(i:i) = b(2:4)(i:i)
+   if (any (b .ne. (/"2","3","4","4"/))) call abort ()
+   b = c
+   forall(i=1:1) b(2:4)(i:i) = b(1:3)(i:i)
+   if (any (b .ne. (/"1","1","2","3"/))) call abort ()
+   b = c
+   do i = 1, 1
+     b(2:4)(i:i) = b(1:3)(i:i)           ! This was PR33811 and Paul's bit
+   end do
+   if (any (b .ne. (/"1","1","2","3"/))) call abort ()
+   call foo
+ contains
+   subroutine foo
+     character(LEN=12) :: a(2) = "123456789012"
+     character(LEN=12) :: b = "123456789012"
+ ! These are Dominique's
+     forall (i = 3:10) a(:)(i:i+2) = a(:)(i-2:i)
+     IF (a(1) .ne. "121234567890") CALL abort ()
+     forall (i = 3:10) a(2)(i:i+2) = a(1)(i-2:i)
+     IF (a(2) .ne. "121212345678") call abort ()
+     forall (i = 3:10) b(i:i+2) = b(i-2:i)
+     IF (b .ne. "121234567890") CALL abort ()
+   end subroutine
+ end
+ 
Index: gcc/testsuite/gfortran.dg/forall_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_13.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/forall_13.f90	(revision 0)
***************
*** 0 ****
--- 1,14 ----
+ ! { dg-do run }
+ ! Tests the fix for PR33686, in which dependencies were not
+ ! correctly handled for the assignments below.
+ !
+ ! Contributed by Dick Hendrickson on comp.lang.fortran,
+ ! " Most elegant syntax for inverting a permutation?" 20071006
+ !
+   integer :: p(4) = (/2,4,1,3/)
+   forall (i = 1:4) p(p(i)) = i                ! This was the original
+   if (any (p .ne. (/3,1,4,2/))) call abort ()
+ 
+   forall (i = 1:4) p(5 - p(i)) = p(5 - i)     ! This is a more complicated version
+   if (any (p .ne. (/1,2,3,4/))) call abort ()
+ end


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