URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [iparity_i4.c] - Blame information for rev 774

Go to most recent revision | Details | Compare with Previous | View Log


/* Implementation of the IPARITY intrinsic
   Copyright 2010 Free Software Foundation, Inc.
   Contributed by Tobias Burnus <burnus@net-b.de>
 
This file is part of the GNU Fortran runtime library (libgfortran).
 
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
 
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
 
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
 
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */
 
#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
 
 
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
 
 
extern void iparity_i4 (gfc_array_i4 * const restrict,
        gfc_array_i4 * const restrict, const index_type * const restrict);
export_proto(iparity_i4);
 
void
iparity_i4 (gfc_array_i4 * const restrict retarray,
        gfc_array_i4 * const restrict array,
        const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_4 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;
 
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 
  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
 
        }
      else
        retarray->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in"
                       " IPARITY intrinsic: is %ld, should be %ld",
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
                       (long int) rank);
 
      if (unlikely (compile_options.bounds_check))
        bounds_ifunction_return ((array_t *) retarray, extent,
                                 "return value", "IPARITY");
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        return;
    }
 
  base = array->data;
  dest = retarray->data;
 
  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_INTEGER_4 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {
 
  result = 0;
        if (len <= 0)
          *dest = 0;
        else
          {
            for (n = 0; n < len; n++, src += delta)
              {
 
  result ^= *src;
              }
 
            *dest = result;
          }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              continue_loop = 0;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}
 
 
extern void miparity_i4 (gfc_array_i4 * const restrict,
        gfc_array_i4 * const restrict, const index_type * const restrict,
        gfc_array_l1 * const restrict);
export_proto(miparity_i4);
 
void
miparity_i4 (gfc_array_i4 * const restrict retarray,
        gfc_array_i4 * const restrict array,
        const index_type * const restrict pdim,
        gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  const GFC_INTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;
 
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;
 
  mbase = mask->data;
 
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");
 
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 
  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] < 0)
        extent[n] = 0;
 
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
        }
      else
        retarray->data = internal_malloc_size (alloc_size);
 
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in IPARITY intrinsic");
 
      if (unlikely (compile_options.bounds_check))
        {
          bounds_ifunction_return ((array_t *) retarray, extent,
                                   "return value", "IPARITY");
          bounds_equal_extents ((array_t *) mask, (array_t *) array,
                                "MASK argument", "IPARITY");
        }
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        return;
    }
 
  dest = retarray->data;
  base = array->data;
 
  while (base)
    {
      const GFC_INTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {
 
  result = 0;
        if (len <= 0)
          *dest = 0;
        else
          {
            for (n = 0; n < len; n++, src += delta, msrc += mdelta)
              {
 
  if (*msrc)
    result ^= *src;
              }
            *dest = result;
          }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          mbase -= mstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}
 
 
extern void siparity_i4 (gfc_array_i4 * const restrict,
        gfc_array_i4 * const restrict, const index_type * const restrict,
        GFC_LOGICAL_4 *);
export_proto(siparity_i4);
 
void
siparity_i4 (gfc_array_i4 * const restrict retarray,
        gfc_array_i4 * const restrict array,
        const index_type * const restrict pdim,
        GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;
 
 
  if (*mask)
    {
      iparity_i4 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] <= 0)
        extent[n] = 0;
    }
 
  for (n = dim; n < rank; n++)
    {
      extent[n] =
        GFC_DESCRIPTOR_EXTENT(array,n + 1);
 
      if (extent[n] <= 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
        }
      else
        retarray->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in"
                       " IPARITY intrinsic: is %ld, should be %ld",
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
                       (long int) rank);
 
      if (unlikely (compile_options.bounds_check))
        {
          for (n=0; n < rank; n++)
            {
              index_type ret_extent;
 
              ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
              if (extent[n] != ret_extent)
                runtime_error ("Incorrect extent in return value of"
                               " IPARITY intrinsic in dimension %ld:"
                               " is %ld, should be %ld", (long int) n + 1,
                               (long int) ret_extent, (long int) extent[n]);
            }
        }
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    }
 
  dest = retarray->data;
 
  while(1)
    {
      *dest = 0;
      count[0]++;
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            return;
          else
            {
              count[n]++;
              dest += dstride[n];
            }
        }
    }
}
 
#endif

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [iparity_i4.c] - Blame information for rev 774

Line No.	Rev	Author	Line
1	733	jeremybenn	`/* Implementation of the IPARITY intrinsic`
2			`Copyright 2010 Free Software Foundation, Inc.`
3			`Contributed by Tobias Burnus <burnus@net-b.de>`
4
5			`This file is part of the GNU Fortran runtime library (libgfortran).`
6
7			`Libgfortran is free software; you can redistribute it and/or`
8			`modify it under the terms of the GNU General Public`
9			`License as published by the Free Software Foundation; either`
10			`version 3 of the License, or (at your option) any later version.`
11
12			`Libgfortran is distributed in the hope that it will be useful,`
13			`but WITHOUT ANY WARRANTY; without even the implied warranty of`
14			`MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
15			`GNU General Public License for more details.`
16
17			`Under Section 7 of GPL version 3, you are granted additional`
18			`permissions described in the GCC Runtime Library Exception, version`
19			`3.1, as published by the Free Software Foundation.`
20
21			`You should have received a copy of the GNU General Public License and`
22			`a copy of the GCC Runtime Library Exception along with this program;`
23			`see the files COPYING3 and COPYING.RUNTIME respectively. If not, see`
24			`<http://www.gnu.org/licenses/>. */`
25
26			`#include "libgfortran.h"`
27			`#include <stdlib.h>`
28			`#include <assert.h>`
29
30
31			`#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)`
32
33
34			`extern void iparity_i4 (gfc_array_i4 * const restrict,`
35			`gfc_array_i4 * const restrict, const index_type * const restrict);`
36			`export_proto(iparity_i4);`
37
38			`void`
39			`iparity_i4 (gfc_array_i4 * const restrict retarray,`
40			`gfc_array_i4 * const restrict array,`
41			`const index_type * const restrict pdim)`
42			`{`
43			`index_type count[GFC_MAX_DIMENSIONS];`
44			`index_type extent[GFC_MAX_DIMENSIONS];`
45			`index_type sstride[GFC_MAX_DIMENSIONS];`
46			`index_type dstride[GFC_MAX_DIMENSIONS];`
47			`const GFC_INTEGER_4 * restrict base;`
48			`GFC_INTEGER_4 * restrict dest;`
49			`index_type rank;`
50			`index_type n;`
51			`index_type len;`
52			`index_type delta;`
53			`index_type dim;`
54			`int continue_loop;`
55
56			`/* Make dim zero based to avoid confusion. */`
57			`dim = (*pdim) - 1;`
58			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
59
60			`len = GFC_DESCRIPTOR_EXTENT(array,dim);`
61			`if (len < 0)`
62			`len = 0;`
63			`delta = GFC_DESCRIPTOR_STRIDE(array,dim);`
64
65			`for (n = 0; n < dim; n++)`
66			`{`
67			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);`
68			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
69
70			`if (extent[n] < 0)`
71			`extent[n] = 0;`
72			`}`
73			`for (n = dim; n < rank; n++)`
74			`{`
75			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);`
76			`extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);`
77
78			`if (extent[n] < 0)`
79			`extent[n] = 0;`
80			`}`
81
82			`if (retarray->data == NULL)`
83			`{`
84			`size_t alloc_size, str;`
85
86			`for (n = 0; n < rank; n++)`
87			`{`
88			`if (n == 0)`
89			`str = 1;`
90			`else`
91			`str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
92
93			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
94
95			`}`
96
97			`retarray->offset = 0;`
98			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
99
100			`alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
101			`* extent[rank-1];`
102
103			`if (alloc_size == 0)`
104			`{`
105			`/* Make sure we have a zero-sized array. */`
106			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
107			`return;`
108
109			`}`
110			`else`
111			`retarray->data = internal_malloc_size (alloc_size);`
112			`}`
113			`else`
114			`{`
115			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
116			`runtime_error ("rank of return array incorrect in"`
117			`" IPARITY intrinsic: is %ld, should be %ld",`
118			`(long int) (GFC_DESCRIPTOR_RANK (retarray)),`
119			`(long int) rank);`
120
121			`if (unlikely (compile_options.bounds_check))`
122			`bounds_ifunction_return ((array_t *) retarray, extent,`
123			`"return value", "IPARITY");`
124			`}`
125
126			`for (n = 0; n < rank; n++)`
127			`{`
128			`count[n] = 0;`
129			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
130			`if (extent[n] <= 0)`
131			`return;`
132			`}`
133
134			`base = array->data;`
135			`dest = retarray->data;`
136
137			`continue_loop = 1;`
138			`while (continue_loop)`
139			`{`
140			`const GFC_INTEGER_4 * restrict src;`
141			`GFC_INTEGER_4 result;`
142			`src = base;`
143			`{`
144
145			`result = 0;`
146			`if (len <= 0)`
147			`*dest = 0;`
148			`else`
149			`{`
150			`for (n = 0; n < len; n++, src += delta)`
151			`{`
152
153			`result ^= *src;`
154			`}`
155
156			`*dest = result;`
157			`}`
158			`}`
159			`/* Advance to the next element. */`
160			`count[0]++;`
161			`base += sstride[0];`
162			`dest += dstride[0];`
163			`n = 0;`
164			`while (count[n] == extent[n])`
165			`{`
166			`/* When we get to the end of a dimension, reset it and increment`
167			`the next dimension. */`
168			`count[n] = 0;`
169			`/* We could precalculate these products, but this is a less`
170			`frequently used path so probably not worth it. */`
171			`base -= sstride[n] * extent[n];`
172			`dest -= dstride[n] * extent[n];`
173			`n++;`
174			`if (n == rank)`
175			`{`
176			`/* Break out of the look. */`
177			`continue_loop = 0;`
178			`break;`
179			`}`
180			`else`
181			`{`
182			`count[n]++;`
183			`base += sstride[n];`
184			`dest += dstride[n];`
185			`}`
186			`}`
187			`}`
188			`}`
189
190
191			`extern void miparity_i4 (gfc_array_i4 * const restrict,`
192			`gfc_array_i4 * const restrict, const index_type * const restrict,`
193			`gfc_array_l1 * const restrict);`
194			`export_proto(miparity_i4);`
195
196			`void`
197			`miparity_i4 (gfc_array_i4 * const restrict retarray,`
198			`gfc_array_i4 * const restrict array,`
199			`const index_type * const restrict pdim,`
200			`gfc_array_l1 * const restrict mask)`
201			`{`
202			`index_type count[GFC_MAX_DIMENSIONS];`
203			`index_type extent[GFC_MAX_DIMENSIONS];`
204			`index_type sstride[GFC_MAX_DIMENSIONS];`
205			`index_type dstride[GFC_MAX_DIMENSIONS];`
206			`index_type mstride[GFC_MAX_DIMENSIONS];`
207			`GFC_INTEGER_4 * restrict dest;`
208			`const GFC_INTEGER_4 * restrict base;`
209			`const GFC_LOGICAL_1 * restrict mbase;`
210			`int rank;`
211			`int dim;`
212			`index_type n;`
213			`index_type len;`
214			`index_type delta;`
215			`index_type mdelta;`
216			`int mask_kind;`
217
218			`dim = (*pdim) - 1;`
219			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
220
221			`len = GFC_DESCRIPTOR_EXTENT(array,dim);`
222			`if (len <= 0)`
223			`return;`
224
225			`mbase = mask->data;`
226
227			`mask_kind = GFC_DESCRIPTOR_SIZE (mask);`
228
229			`if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8`
230			`#ifdef HAVE_GFC_LOGICAL_16`
231			`\|\| mask_kind == 16`
232			`#endif`
233			`)`
234			`mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);`
235			`else`
236			`runtime_error ("Funny sized logical array");`
237
238			`delta = GFC_DESCRIPTOR_STRIDE(array,dim);`
239			`mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);`
240
241			`for (n = 0; n < dim; n++)`
242			`{`
243			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);`
244			`mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);`
245			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
246
247			`if (extent[n] < 0)`
248			`extent[n] = 0;`
249
250			`}`
251			`for (n = dim; n < rank; n++)`
252			`{`
253			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);`
254			`mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);`
255			`extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);`
256
257			`if (extent[n] < 0)`
258			`extent[n] = 0;`
259			`}`
260
261			`if (retarray->data == NULL)`
262			`{`
263			`size_t alloc_size, str;`
264
265			`for (n = 0; n < rank; n++)`
266			`{`
267			`if (n == 0)`
268			`str = 1;`
269			`else`
270			`str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
271
272			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
273
274			`}`
275
276			`alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
277			`* extent[rank-1];`
278
279			`retarray->offset = 0;`
280			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
281
282			`if (alloc_size == 0)`
283			`{`
284			`/* Make sure we have a zero-sized array. */`
285			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
286			`return;`
287			`}`
288			`else`
289			`retarray->data = internal_malloc_size (alloc_size);`
290
291			`}`
292			`else`
293			`{`
294			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
295			`runtime_error ("rank of return array incorrect in IPARITY intrinsic");`
296
297			`if (unlikely (compile_options.bounds_check))`
298			`{`
299			`bounds_ifunction_return ((array_t *) retarray, extent,`
300			`"return value", "IPARITY");`
301			`bounds_equal_extents ((array_t ) mask, (array_t ) array,`
302			`"MASK argument", "IPARITY");`
303			`}`
304			`}`
305
306			`for (n = 0; n < rank; n++)`
307			`{`
308			`count[n] = 0;`
309			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
310			`if (extent[n] <= 0)`
311			`return;`
312			`}`
313
314			`dest = retarray->data;`
315			`base = array->data;`
316
317			`while (base)`
318			`{`
319			`const GFC_INTEGER_4 * restrict src;`
320			`const GFC_LOGICAL_1 * restrict msrc;`
321			`GFC_INTEGER_4 result;`
322			`src = base;`
323			`msrc = mbase;`
324			`{`
325
326			`result = 0;`
327			`if (len <= 0)`
328			`*dest = 0;`
329			`else`
330			`{`
331			`for (n = 0; n < len; n++, src += delta, msrc += mdelta)`
332			`{`
333
334			`if (*msrc)`
335			`result ^= *src;`
336			`}`
337			`*dest = result;`
338			`}`
339			`}`
340			`/* Advance to the next element. */`
341			`count[0]++;`
342			`base += sstride[0];`
343			`mbase += mstride[0];`
344			`dest += dstride[0];`
345			`n = 0;`
346			`while (count[n] == extent[n])`
347			`{`
348			`/* When we get to the end of a dimension, reset it and increment`
349			`the next dimension. */`
350			`count[n] = 0;`
351			`/* We could precalculate these products, but this is a less`
352			`frequently used path so probably not worth it. */`
353			`base -= sstride[n] * extent[n];`
354			`mbase -= mstride[n] * extent[n];`
355			`dest -= dstride[n] * extent[n];`
356			`n++;`
357			`if (n == rank)`
358			`{`
359			`/* Break out of the look. */`
360			`base = NULL;`
361			`break;`
362			`}`
363			`else`
364			`{`
365			`count[n]++;`
366			`base += sstride[n];`
367			`mbase += mstride[n];`
368			`dest += dstride[n];`
369			`}`
370			`}`
371			`}`
372			`}`
373
374
375			`extern void siparity_i4 (gfc_array_i4 * const restrict,`
376			`gfc_array_i4 * const restrict, const index_type * const restrict,`
377			`GFC_LOGICAL_4 *);`
378			`export_proto(siparity_i4);`
379
380			`void`
381			`siparity_i4 (gfc_array_i4 * const restrict retarray,`
382			`gfc_array_i4 * const restrict array,`
383			`const index_type * const restrict pdim,`
384			`GFC_LOGICAL_4 * mask)`
385			`{`
386			`index_type count[GFC_MAX_DIMENSIONS];`
387			`index_type extent[GFC_MAX_DIMENSIONS];`
388			`index_type dstride[GFC_MAX_DIMENSIONS];`
389			`GFC_INTEGER_4 * restrict dest;`
390			`index_type rank;`
391			`index_type n;`
392			`index_type dim;`
393
394
395			`if (*mask)`
396			`{`
397			`iparity_i4 (retarray, array, pdim);`
398			`return;`
399			`}`
400			`/* Make dim zero based to avoid confusion. */`
401			`dim = (*pdim) - 1;`
402			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
403
404			`for (n = 0; n < dim; n++)`
405			`{`
406			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
407
408			`if (extent[n] <= 0)`
409			`extent[n] = 0;`
410			`}`
411
412			`for (n = dim; n < rank; n++)`
413			`{`
414			`extent[n] =`
415			`GFC_DESCRIPTOR_EXTENT(array,n + 1);`
416
417			`if (extent[n] <= 0)`
418			`extent[n] = 0;`
419			`}`
420
421			`if (retarray->data == NULL)`
422			`{`
423			`size_t alloc_size, str;`
424
425			`for (n = 0; n < rank; n++)`
426			`{`
427			`if (n == 0)`
428			`str = 1;`
429			`else`
430			`str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
431
432			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
433
434			`}`
435
436			`retarray->offset = 0;`
437			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
438
439			`alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
440			`* extent[rank-1];`
441
442			`if (alloc_size == 0)`
443			`{`
444			`/* Make sure we have a zero-sized array. */`
445			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
446			`return;`
447			`}`
448			`else`
449			`retarray->data = internal_malloc_size (alloc_size);`
450			`}`
451			`else`
452			`{`
453			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
454			`runtime_error ("rank of return array incorrect in"`
455			`" IPARITY intrinsic: is %ld, should be %ld",`
456			`(long int) (GFC_DESCRIPTOR_RANK (retarray)),`
457			`(long int) rank);`
458
459			`if (unlikely (compile_options.bounds_check))`
460			`{`
461			`for (n=0; n < rank; n++)`
462			`{`
463			`index_type ret_extent;`
464
465			`ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);`
466			`if (extent[n] != ret_extent)`
467			`runtime_error ("Incorrect extent in return value of"`
468			`" IPARITY intrinsic in dimension %ld:"`
469			`" is %ld, should be %ld", (long int) n + 1,`
470			`(long int) ret_extent, (long int) extent[n]);`
471			`}`
472			`}`
473			`}`
474
475			`for (n = 0; n < rank; n++)`
476			`{`
477			`count[n] = 0;`
478			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
479			`}`
480
481			`dest = retarray->data;`
482
483			`while(1)`
484			`{`
485			`*dest = 0;`
486			`count[0]++;`
487			`dest += dstride[0];`
488			`n = 0;`
489			`while (count[n] == extent[n])`
490			`{`
491			`/* When we get to the end of a dimension, reset it and increment`
492			`the next dimension. */`
493			`count[n] = 0;`
494			`/* We could precalculate these products, but this is a less`
495			`frequently used path so probably not worth it. */`
496			`dest -= dstride[n] * extent[n];`
497			`n++;`
498			`if (n == rank)`
499			`return;`
500			`else`
501			`{`
502			`count[n]++;`
503			`dest += dstride[n];`
504			`}`
505			`}`
506			`}`
507			`}`
508
509			`#endif`