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] PR16206 - array initializers


:ADDPATCH fortran:

This patch permits gfortran to digest initializers like

program gfortran_bug1
real, parameter :: x(2) = (/ 1.0, 2.0 /)
real, parameter :: y(4) = (/ x(1:2), x(1:2) /)
end program gfortran_bug1

The new function find_array_section, called from gfc_simplify_expr does this job. It is a straightforward, albeit heavy going, bit of mpz-ery to cycle through the array reference, adding the elements to a new constructor expression and then eliminating the old. I had to add bounds checking because segfaults were caused otherwise.

Having done this, I realised that the extra step of allowing index expressions that involved implied do loop variables was a small one. The only trickery here was to restrict the call to gfc_expand_constructor to full arrays because the subsequent call to simplify_constant_ref was doing the job for other kinds of array.

Finally, it was a small addition to allow substring references; this is done in find_substring_ref. The testcase attempts to verify these new features. No other compiler that I can lay hands on is able to handle them all.

Regtested on FC5/Athlon. OK for trunk and 4.1?

Paul T

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.


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,974 ----
  
  /* 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;
  
    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->upper[i]->value.integer) > 0
! 	    || mpz_cmp (e->value.integer,
! 			ar->as->lower[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 ****
--- 1008,1225 ----
  }
  
  
+ /* 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;
+ 
+   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);
+ 
+   /* 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;
+ 
+       /* Obtain the stride.  */
+       if (step)
+ 	mpz_init_set (stride[idx], step->value.integer);
+       else
+ 	mpz_init_set_ui (stride[idx], one);
+ 
+       if (mpz_cmp_ui (stride[idx], 0) == 0)
+ 	mpz_set_ui (stride[idx], one);
+ 
+       /* Obtain the start value for the index.  */
+       if (begin->value.integer)
+ 	  mpz_init_set (ctr[idx], begin->value.integer);
+       else
+ 	{
+ 	  if (mpz_cmp_si (stride[idx], 0) < 0)
+ 	    mpz_init_set (ctr[idx], upper->value.integer);
+ 	  else
+ 	    mpz_init_set (ctr[idx], lower->value.integer);
+ 	}
+ 
+       /* Obtain the end value for the index.  */
+       if (finish)
+         mpz_init_set (end [idx], finish->value.integer);
+       else
+ 	{
+ 	  if (mpz_cmp_si (stride[idx], 0) < 0)
+ 	    mpz_init_set (end[idx], lower->value.integer);
+ 	  else
+ 	    mpz_init_set (end[idx], upper->value.integer);
+ 	}
+ 
+       /* Separate 'if' because elements sometimes arrive with
+ 	 non-null end.  */
+       if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
+ 	mpz_init_set (end [idx], begin->value.integer);
+ 
+       /* Check the bounds.  */
+       if (mpz_cmp (ctr[idx], upper->value.integer) > 0
+ 	    || mpz_cmp (end[idx], upper->value.integer) > 0
+ 	    || mpz_cmp (ctr[idx], lower->value.integer) < 0
+ 	    || mpz_cmp (end[idx], lower->value.integer) < 0)
+ 	{
+ 	  gfc_error ("index in dimension %d is out of bounds "
+ 		     "at %L", idx + 1, &ref->u.ar.c_where[idx]);
+ 	  return FAILURE;
+ 	}
+ 
+       /* Calculate the number of elements and the shape.  */
+       mpz_abs (tmp_mpz, stride[idx]);
+       mpz_div (tmp_mpz, stride[idx], tmp_mpz);
+       mpz_add (tmp_mpz, end[idx], tmp_mpz);
+       mpz_sub (tmp_mpz, tmp_mpz, ctr[idx]);
+       mpz_div (tmp_mpz, tmp_mpz, stride[idx]);
+       mpz_mul (nelts, nelts, tmp_mpz);
+ 
+       mpz_set (expr->shape[idx], tmp_mpz);
+ 
+       /* Calculate the 'stride' (=delta) for conversion of the
+ 	 counter values into the index along the constructor.  */
+       mpz_init_set (delta[idx], 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);
+   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_init_set (ptr, ref->u.ar.offset->value.integer);
+       else
+ 	mpz_init (ptr);
+ 
+       mpz_init_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 (delta_mpz);
+   mpz_clear (tmp_mpz);
+   mpz_clear (ptr);
+   mpz_clear (nelts);
+   mpz_clear (stop);
+   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 SUCCESS;
+ }
+ 
+ /* 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 ****
--- 1227,1233 ----
  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;
  	    }
  
--- 1237,1274 ----
  	  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;
  	}
      }
  
--- 1280,1292 ----
  	  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 ****
--- 1317,1323 ----
  	      if (gfc_simplify_expr (ref->u.ar.stride[n], type)
  		     == FAILURE)
  		return FAILURE;
+ 
  	    }
  	  break;
  
*************** 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)
--- 1467,1475 ----
        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/testsuite/gfortran.dg/array_initializer_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/array_initializer_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/array_initializer_1.f90	(revision 0)
***************
*** 0 ****
--- 1,36 ----
+ ! { dg-do run }
+ ! Check the fix for PR16206, in which array sections would not work
+ ! in array initializers. Use of implied do loop variables for indices
+ ! and substrings, with and without implied do loops, were fixed at the
+ ! same time.
+ !
+ ! Contributed by Paul Thomas   <pault@gcc.gnu.org>
+ ! based on testcase from Harald Anlauf  <anlauf@gmx.de>  
+ !
+   real, parameter :: x(4,4) = reshape((/(i, i = 1, 16)/), (/4,4/))
+   real, parameter :: y(4) = (/ x(1:2, 2), x(3:4, 4)/)
+   real, parameter :: z(2) = x(2:3, 3) + 1
+   real, parameter :: r(6) = (/(x(i:i +1, i), i = 1,3)/)
+   real, parameter :: s(12) = (/((x(i, i:j-1:-1), i = 3,4), j = 2,3)/)
+   real, parameter :: t(8) = (/(z, &
+ 	real (i)**3, y(i), i = 2, 3)/) ! { dg-warning "nonstandard" }
+ 
+   integer, parameter :: ii = 4
+ 
+   character(4), parameter :: chr(4) = (/"abcd", "efgh", "ijkl", "mnop"/)
+   character(4), parameter :: chrs = chr(ii)(2:3)//chr(2)(ii-3:ii-2) 
+   character(4), parameter :: chrt(2) = (/chr(2:2)(2:3), chr(ii-1)(3:ii)/)
+   character(2), parameter :: chrx(2) = (/(chr(i)(i:i+1), i=2,3)/)
+ 
+   if (any (y .ne. (/5., 6., 15., 16./))) call abort ()
+   if (any (z .ne. (/11., 12./))) call abort ()
+   if (any (r .ne. (/1., 2., 6., 7., 11., 12./))) call abort ()
+   if (any (s .ne. (/11., 7., 3., 16., 12., 8., 4., &
+ 		    11., 7.,     16., 12., 8. /))) call abort ()
+ 
+   if (any (t .ne. (/11., 12., 8., 6., 11., 12., 27., 15. /))) call abort ()
+ 
+   if (chrs .ne. "noef") call abort ()
+   if (any (chrt .ne. (/"fg", "kl"/))) call abort ()
+   if (any (chrx .ne. (/"fg", "kl"/))) call abort ()
+ end
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.
  

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