Re: [Patch, fortran] PR16206 - array initializers

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

Steve,

The attached responds to your questions/details.  It regtests on 
FC5/Athlon.  Is it OK with the original testcase?

I realised a few minutes ago that the submitted version of the 
transformational intrinsics patch was (i) not the final version in 
simplify.c and (ii) was missing a small correction in 
expr.c(simplify_parameter_variable).  This latter appears in the new 
version of the PR16206 patch, and I have attached the correct version of 
the simplify.c patch; sorry for that.

I'll wait for you to OK both before committing.

Many thanks, especially for picking up the memory leaks.

Paul

> On Sat, Jun 17, 2006 at 06:57:16AM +0200, Paul Thomas wrote:
>  
>
> > 2006-06-17  Paul Thomas  <pault@gcc.gnu.org>
> >
> >   PR fortran/16206
> >   * expr.c (find_array_element): Eliminate condition on length of
> >   offset. Add bounds checking. Rearrange exit. Return try and
> >   put gfc_constructor result as an argument.
> >   (find_array_section): New function.
> >   (find_substring_ref): New function.
> >   (simplify_const_ref): Add calls to previous.
> >   (gfc_simplify_expr): Only call gfc_expand_constructor for full
> >   arrays.
> >
> > 2006-06-17  Paul Thomas  <pault@gcc.gnu.org>
> >
> >   PR fortran/16206
> >   * gfortran.dg/array_initializer_1.f90: New test.
> >
> >
> >    
>
> There a few minor questions/details to consider see below.
>
> ! 
> !       /* Check the bounds.  */
> !       if (ar->as->upper[i]
> ! 	    && (mpz_cmp (e->value.integer,
> ! 			ar->as->upper[i]->value.integer) > 0
> ! 	    || mpz_cmp (e->value.integer,
> ! 			ar->as->upper[i]->value.integer) > 0
>
> These mpz_cmp appear to be redundant.
>
> ! 	    || mpz_cmp (e->value.integer,
> ! 			ar->as->lower[i]->value.integer) < 0
> ! 	    || mpz_cmp (e->value.integer,
> ! 			ar->as->lower[i]->value.integer) < 0))
>
> These mpz_cmp appear to be redundant.
>
> *************** remove_subobject_ref (gfc_expr * p, gfc_
> *** 985,990 ****
> --- 1008,1225 ----
>  }
> +   if (expr->shape == NULL)
> +     expr->shape = gfc_get_shape (rank);
> + 
> +   mpz_init_set_ui (delta_mpz, one);
> +   mpz_init_set_ui (nelts, one);
> +   mpz_init (tmp_mpz);
> + 
> +   /* Build the counters to clock through the array reference.  */
> +   for (idx = 0; idx < rank; idx++)
> +     {
> +       /* Make this stretch of code easier on the eye!  */
> +       begin = ref->u.ar.start[idx];
> +       finish = ref->u.ar.end[idx];
> +       step = ref->u.ar.stride[idx];
> +       lower = ref->u.ar.as->lower[idx];
> +       upper = ref->u.ar.as->upper[idx];
> + 
> +       if ((begin && begin->expr_type != EXPR_CONSTANT)
> + 	    || (finish && finish->expr_type != EXPR_CONSTANT)
> + 	    || (step && step->expr_type != EXPR_CONSTANT))
> + 	    return FAILURE;
>
> Doesn't this "return FAILURE" leak memory?  Should you free at least the
> mpz variables?
>
> + 	{
> + 	  gfc_error ("index in dimension %d is out of bounds "
> + 		     "at %L", idx + 1, &ref->u.ar.c_where[idx]);
> + 	  return FAILURE;
>
> Again, is memory leaked here?
>
>
>  

Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 114548)
--- gcc/fortran/expr.c	(working copy)
*************** simplify_constructor (gfc_constructor * 
*** 902,951 ****
  
  /* Pull a single array element out of an array constructor.  */
  
! static gfc_constructor *
! find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
  {
    unsigned long nelemen;
    int i;
    mpz_t delta;
    mpz_t offset;
  
    mpz_init_set_ui (offset, 0);
    mpz_init (delta);
    for (i = 0; i < ar->dimen; i++)
      {
!       if (ar->start[i]->expr_type != EXPR_CONSTANT)
  	{
  	  cons = NULL;
! 	  break;
  	}
!       mpz_sub (delta, ar->start[i]->value.integer,
  	       ar->as->lower[i]->value.integer);
        mpz_add (offset, offset, delta);
      }
  
    if (cons)
      {
!       if (mpz_fits_ulong_p (offset))
  	{
! 	  for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
  	    {
! 	      if (cons->iterator)
! 		{
! 		  cons = NULL;
! 		  break;
! 		}
! 	      cons = cons->next;
  	    }
  	}
-       else
- 	cons = NULL;
      }
  
    mpz_clear (delta);
    mpz_clear (offset);
! 
!   return cons;
  }
  
  
--- 902,971 ----
  
  /* Pull a single array element out of an array constructor.  */
  
! static try
! find_array_element (gfc_constructor * cons, gfc_array_ref * ar,
! 		    gfc_constructor ** rval)
  {
    unsigned long nelemen;
    int i;
    mpz_t delta;
    mpz_t offset;
+   gfc_expr *e;
+   try t;
+ 
+   t = SUCCESS;
+   e = NULL;
  
    mpz_init_set_ui (offset, 0);
    mpz_init (delta);
    for (i = 0; i < ar->dimen; i++)
      {
!       e = gfc_copy_expr (ar->start[i]);
!       if (e->expr_type != EXPR_CONSTANT)
  	{
  	  cons = NULL;
! 	  goto depart;
  	}
! 
!       /* Check the bounds.  */
!       if (ar->as->upper[i]
! 	    && (mpz_cmp (e->value.integer,
! 			ar->as->upper[i]->value.integer) > 0
! 	    || mpz_cmp (e->value.integer,
! 			ar->as->lower[i]->value.integer) < 0))
! 	{
! 	  gfc_error ("index in dimension %d is out of bounds "
! 		     "at %L", i + 1, &ar->c_where[i]);
! 	  cons = NULL;
! 	  t = FAILURE;
! 	  goto depart;
! 	}
! 
!       mpz_sub (delta, e->value.integer,
  	       ar->as->lower[i]->value.integer);
        mpz_add (offset, offset, delta);
      }
  
    if (cons)
      {
!       for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
  	{
! 	  if (cons->iterator)
  	    {
! 	      cons = NULL;
! 	      goto depart;
  	    }
+ 	  cons = cons->next;
  	}
      }
  
+ depart:
    mpz_clear (delta);
    mpz_clear (offset);
!   if (e)
!     gfc_free_expr (e);
!   *rval = cons;
!   return t;
  }
  
  
*************** remove_subobject_ref (gfc_expr * p, gfc_
*** 985,990 ****
--- 1005,1244 ----
  }
  
  
+ /* Pull an array section out of an array constructor.  */
+ 
+ static try
+ find_array_section (gfc_expr *expr, gfc_ref *ref)
+ {
+   int idx;
+   int rank;
+   int d;
+   long unsigned one = 1;
+   mpz_t end[GFC_MAX_DIMENSIONS];
+   mpz_t stride[GFC_MAX_DIMENSIONS];
+   mpz_t delta[GFC_MAX_DIMENSIONS];
+   mpz_t ctr[GFC_MAX_DIMENSIONS];
+   mpz_t delta_mpz;
+   mpz_t tmp_mpz;
+   mpz_t nelts;
+   mpz_t ptr;
+   mpz_t stop;
+   mpz_t index;
+   gfc_constructor *cons;
+   gfc_constructor *base;
+   gfc_expr *begin;
+   gfc_expr *finish;
+   gfc_expr *step;
+   gfc_expr *upper;
+   gfc_expr *lower;
+   try t;
+ 
+   t = SUCCESS;
+ 
+   base = expr->value.constructor;
+   expr->value.constructor = NULL;
+ 
+   rank = ref->u.ar.as->rank;
+ 
+   if (expr->shape == NULL)
+     expr->shape = gfc_get_shape (rank);
+ 
+   mpz_init_set_ui (delta_mpz, one);
+   mpz_init_set_ui (nelts, one);
+   mpz_init (tmp_mpz);
+ 
+   /* Do the initialization now, so that we can cleanup without
+      keeping track of where we were.  */
+   for (d = 0; d < rank; d++)
+     {
+       mpz_init (delta[d]);
+       mpz_init (end[d]);
+       mpz_init (ctr[d]);
+       mpz_init (stride[d]);
+     }
+ 
+   /* Build the counters to clock through the array reference.  */
+   for (d = 0; d < rank; d++)
+     {
+       /* Make this stretch of code easier on the eye!  */
+       begin = ref->u.ar.start[d];
+       finish = ref->u.ar.end[d];
+       step = ref->u.ar.stride[d];
+       lower = ref->u.ar.as->lower[d];
+       upper = ref->u.ar.as->upper[d];
+ 
+       if ((begin && begin->expr_type != EXPR_CONSTANT)
+ 	    || (finish && finish->expr_type != EXPR_CONSTANT)
+ 	    || (step && step->expr_type != EXPR_CONSTANT))
+ 	{
+ 	  t = FAILURE;
+ 	  goto cleanup;
+ 	}
+ 
+       /* Obtain the stride.  */
+       if (step)
+ 	mpz_set (stride[d], step->value.integer);
+       else
+ 	mpz_set_ui (stride[d], one);
+ 
+       if (mpz_cmp_ui (stride[d], 0) == 0)
+ 	mpz_set_ui (stride[d], one);
+ 
+       /* Obtain the start value for the index.  */
+       if (begin->value.integer)
+ 	  mpz_set (ctr[d], begin->value.integer);
+       else
+ 	{
+ 	  if (mpz_cmp_si (stride[d], 0) < 0)
+ 	    mpz_set (ctr[d], upper->value.integer);
+ 	  else
+ 	    mpz_set (ctr[d], lower->value.integer);
+ 	}
+ 
+       /* Obtain the end value for the index.  */
+       if (finish)
+         mpz_set (end[d], finish->value.integer);
+       else
+ 	{
+ 	  if (mpz_cmp_si (stride[d], 0) < 0)
+ 	    mpz_set (end[d], lower->value.integer);
+ 	  else
+ 	    mpz_set (end[d], upper->value.integer);
+ 	}
+ 
+       /* Separate 'if' because elements sometimes arrive with
+ 	 non-null end.  */
+       if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
+ 	mpz_set (end [d], begin->value.integer);
+ 
+       /* Check the bounds.  */
+       if (mpz_cmp (ctr[d], upper->value.integer) > 0
+ 	    || mpz_cmp (end[d], upper->value.integer) > 0
+ 	    || mpz_cmp (ctr[d], lower->value.integer) < 0
+ 	    || mpz_cmp (end[d], lower->value.integer) < 0)
+ 	{
+ 	  gfc_error ("index in dimension %d is out of bounds "
+ 		     "at %L", d + 1, &ref->u.ar.c_where[d]);
+ 	  t = FAILURE;
+ 	  goto cleanup;
+ 	}
+ 
+       /* Calculate the number of elements and the shape.  */
+       mpz_abs (tmp_mpz, stride[d]);
+       mpz_div (tmp_mpz, stride[d], tmp_mpz);
+       mpz_add (tmp_mpz, end[d], tmp_mpz);
+       mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
+       mpz_div (tmp_mpz, tmp_mpz, stride[d]);
+       mpz_mul (nelts, nelts, tmp_mpz);
+ 
+       mpz_set (expr->shape[d], tmp_mpz);
+ 
+       /* Calculate the 'stride' (=delta) for conversion of the
+ 	 counter values into the index along the constructor.  */
+       mpz_set (delta[d], delta_mpz);
+       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
+       mpz_add_ui (tmp_mpz, tmp_mpz, one);
+       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
+     }
+ 
+   mpz_init (index);
+   mpz_init (ptr);
+   mpz_init (stop);
+   cons = base;
+ 
+   /* Now clock through the array reference, calculating the index in
+      the source constructor and transferring the elements to the new
+      constructor.  */  
+   for (idx = 0; idx < (int)mpz_get_si (nelts); idx++)
+     {
+       if (ref->u.ar.offset)
+ 	mpz_set (ptr, ref->u.ar.offset->value.integer);
+       else
+ 	mpz_init_set_ui (ptr, 0);
+ 
+       mpz_set_ui (stop, one);
+       for (d = 0; d < rank; d++)
+ 	{
+ 	  mpz_set (tmp_mpz, ctr[d]);
+ 	  mpz_sub_ui (tmp_mpz, tmp_mpz, one);
+ 	  mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
+ 	  mpz_add (ptr, ptr, tmp_mpz);
+ 
+ 	  mpz_mul (tmp_mpz, stride[d], stop);
+ 	  mpz_add (ctr[d], ctr[d], tmp_mpz); 
+ 
+ 	  mpz_set (tmp_mpz, end[d]);
+ 	  if (mpz_cmp_ui (stride[d], 0) > 0 ?
+ 		mpz_cmp (ctr[d], tmp_mpz) > 0 :
+ 		mpz_cmp (ctr[d], tmp_mpz) < 0)
+ 	    mpz_set (ctr[d], ref->u.ar.start[d]->value.integer);
+ 	  else
+ 	    mpz_set_ui (stop, 0);
+ 	}
+ 
+       /* There must be a better way of dealing with negative strides
+ 	 than resetting the index and the constructor pointer!  */ 
+       if (mpz_cmp (ptr, index) < 0)
+ 	{
+ 	  mpz_init (index);
+ 	  cons = base;
+ 	}
+ 
+       while (mpz_cmp (ptr, index) > 0)
+ 	{
+ 	  mpz_add_ui (index, index, one);
+ 	  cons = cons->next;
+ 	}
+ 
+       gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+     }
+ 
+   mpz_clear (ptr);
+   mpz_clear (index);
+   mpz_clear (stop);
+ 
+ cleanup:
+ 
+   mpz_clear (delta_mpz);
+   mpz_clear (tmp_mpz);
+   mpz_clear (nelts);
+   for (d = 0; d < rank; d++)
+     {
+       mpz_clear (delta[d]);
+       mpz_clear (end[d]);
+       mpz_clear (ctr[d]);
+       mpz_clear (stride[d]);
+     }
+   gfc_free_constructor (base);
+   return t;
+ }
+ 
+ /* Pull a substring out of an expression.  */
+ 
+ static try
+ find_substring_ref (gfc_expr *p, gfc_expr **newp)
+ {
+   int end;
+   int start;
+   char *chr;
+ 
+   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
+ 	|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
+     return FAILURE;
+ 
+   *newp = gfc_copy_expr (p);
+   chr = p->value.character.string;
+   end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer);
+   start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer);
+ 
+   (*newp)->value.character.length = end - start + 1;
+   strncpy ((*newp)->value.character.string, &chr[start - 1],
+ 	   (*newp)->value.character.length);
+   return SUCCESS;
+ }
+ 
+ 
+ 
  /* Simplify a subobject reference of a constructor.  This occurs when
     parameter variable values are substituted.  */
  
*************** static try
*** 992,997 ****
--- 1246,1252 ----
  simplify_const_ref (gfc_expr * p)
  {
    gfc_constructor *cons;
+   gfc_expr *newp;
  
    while (p->ref)
      {
*************** simplify_const_ref (gfc_expr * p)
*** 1001,1024 ****
  	  switch (p->ref->u.ar.type)
  	    {
  	    case AR_ELEMENT:
! 	      cons = find_array_element (p->value.constructor, &p->ref->u.ar);
  	      if (!cons)
  		return SUCCESS;
  	      remove_subobject_ref (p, cons);
  	      break;
  
  	    case AR_FULL:
! 	      if (p->ref->next != NULL)
  		{
! 		  /* TODO: Simplify array subobject references.  */
! 		  return SUCCESS;
  		}
! 		gfc_free_ref_list (p->ref);
! 		p->ref = NULL;
  	      break;
  
  	    default:
- 	      /* TODO: Simplify array subsections.  */
  	      return SUCCESS;
  	    }
  
--- 1256,1293 ----
  	  switch (p->ref->u.ar.type)
  	    {
  	    case AR_ELEMENT:
! 	      if (find_array_element (p->value.constructor,
! 				      &p->ref->u.ar,
! 				      &cons) == FAILURE)
! 		return FAILURE;
! 
  	      if (!cons)
  		return SUCCESS;
+ 
  	      remove_subobject_ref (p, cons);
  	      break;
  
+ 	    case AR_SECTION:
+ 	      if (find_array_section (p, p->ref) == FAILURE)
+ 		return FAILURE;
+ 	      p->ref->u.ar.type = AR_FULL;
+ 
  	    case AR_FULL:
! 	      if (p->ref->next != NULL
! 		    && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
  		{
! 		  cons = p->value.constructor;
! 		  for (; cons; cons = cons->next)
! 		    {
! 		      cons->expr->ref = copy_ref (p->ref->next);
! 		      simplify_const_ref (cons->expr);
! 		    }
  		}
! 	      gfc_free_ref_list (p->ref);
! 	      p->ref = NULL;
  	      break;
  
  	    default:
  	      return SUCCESS;
  	    }
  
*************** simplify_const_ref (gfc_expr * p)
*** 1030,1037 ****
  	  break;
  
  	case REF_SUBSTRING:
! 	  /* TODO: Constant substrings.  */
! 	  return SUCCESS;
  	}
      }
  
--- 1299,1311 ----
  	  break;
  
  	case REF_SUBSTRING:
!   	  if (find_substring_ref (p, &newp) == FAILURE)
! 	    return FAILURE;
! 
! 	  gfc_replace_expr (p, newp);
! 	  gfc_free_ref_list (p->ref);
! 	  p->ref = NULL;
! 	  break;
  	}
      }
  
*************** simplify_ref_chain (gfc_ref * ref, int t
*** 1062,1067 ****
--- 1336,1342 ----
  	      if (gfc_simplify_expr (ref->u.ar.stride[n], type)
  		     == FAILURE)
  		return FAILURE;
+ 
  	    }
  	  break;
  
*************** simplify_parameter_variable (gfc_expr * 
*** 1088,1093 ****
--- 1363,1371 ----
    try t;
  
    e = gfc_copy_expr (p->symtree->n.sym->value);
+   if (e == NULL)
+     return FAILURE;
+ 
    /* Do not copy subobject refs for constant.  */
    if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
      e->ref = copy_ref (p->ref);
*************** gfc_simplify_expr (gfc_expr * p, int typ
*** 1211,1217 ****
        if (simplify_constructor (p->value.constructor, type) == FAILURE)
  	return FAILURE;
  
!       if (p->expr_type == EXPR_ARRAY)
  	  gfc_expand_constructor (p);
  
        if (simplify_const_ref (p) == FAILURE)
--- 1489,1497 ----
        if (simplify_constructor (p->value.constructor, type) == FAILURE)
  	return FAILURE;
  
!       if (p->expr_type == EXPR_ARRAY
! 	    && p->ref && p->ref->type == REF_ARRAY
! 	    && p->ref->u.ar.type == AR_FULL)
  	  gfc_expand_constructor (p);
  
        if (simplify_const_ref (p) == FAILURE)

Index: gcc/fortran/simplify.c
===================================================================
*** gcc/fortran/simplify.c	(revision 114548)
--- gcc/fortran/simplify.c	(working copy)
*************** gfc_simplify_tiny (gfc_expr * e)
*** 3696,3701 ****
--- 3696,3714 ----
  
  
  gfc_expr *
+ gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size)
+ {
+ 
+   /* Reference mold and size to suppress warning.  */
+   if (gfc_init_expr && (mold || size))
+     gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
+ 	       &source->where);
+ 
+   return NULL;
+ }
+ 
+ 
+ gfc_expr *
  gfc_simplify_trim (gfc_expr * e)
  {
    gfc_expr *result;