This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[gfortran] Implement CSHIFT
- From: Paul Brook <paul at nowt dot org>
- To: "gcc-patches at gcc dot gnu dot org" <gcc-patches at gcc dot gnu dot org>,fortran at gcc dot gnu dot org
- Date: Sun, 12 Oct 2003 23:01:55 +0100
- Subject: [gfortran] Implement CSHIFT
The attached patch implements the CSHIFT intrinsic.
Applied to tree-ssa branch.
Paul
2003-10-12 Feng Wang <wf_cs@yahoo.com>
* iresolve.c (gfc_resolve_cshift): Change to match implementation.
* trans-intrinsic.c (gfc_conv_intrinsic_function): Remove CSHIFT.
(gfc_is_intrinsic_libcall): Add CSHIFT.
libgfortran
* intrinsics/cshift0.c: New file.
* m4/cshift1.m4: New file
* generated/cshift*.c: New files.
* Makefile.am: Add them.
* Makefile.in: Regenerate.
testsuite
* gfortran.fortran-torture/execute/intrinsic_cshift.f90: New test.
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/Attic/iresolve.c,v
retrieving revision 1.1.2.3
diff -u -r1.1.2.3 iresolve.c
--- gcc/fortran/iresolve.c 11 Oct 2003 19:28:10 -0000 1.1.2.3
+++ gcc/fortran/iresolve.c 12 Oct 2003 21:57:23 -0000
@@ -1,5 +1,5 @@
/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GNU G95.
@@ -375,21 +375,28 @@
void
gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
- gfc_expr * shift ATTRIBUTE_UNUSED,
+ gfc_expr * shift,
gfc_expr * dim)
{
- static char cshift0[] = "__cshift0", cshift1[] = "__cshift1";
+ int n;
f->ts = array->ts;
f->rank = array->rank;
- if (dim == NULL)
- f->value.function.name = cshift0;
+ if (shift->rank > 0)
+ n = 1;
else
+ n = 0;
+
+ if (dim != NULL)
{
gfc_resolve_index (dim, 1);
- f->value.function.name = cshift1;
+ /* Convert dim to shift's kind, so we don't need so many variations. */
+ if (dim->ts.kind != shift->ts.kind)
+ gfc_convert_type (dim, &shift->ts, 2);
}
+ f->value.function.name =
+ gfc_get_string ("__cshift%d_%d", n, shift->ts.kind);
}
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/Attic/trans-intrinsic.c,v
retrieving revision 1.1.2.15
diff -u -r1.1.2.15 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c 12 Oct 2003 14:53:03 -0000 1.1.2.15
+++ gcc/fortran/trans-intrinsic.c 12 Oct 2003 21:57:28 -0000
@@ -3071,9 +3071,6 @@
case GFC_ISYM_NONE:
abort ();
- case GFC_ISYM_CSHIFT:
- gfc_todo_error ("Intrinsic %s", expr->value.function.name);
-
case GFC_ISYM_REPEAT:
gfc_conv_intrinsic_repeat (se, expr);
break;
@@ -3458,6 +3455,7 @@
return 1;
case GFC_ISYM_RESHAPE:
+ case GFC_ISYM_CSHIFT:
case GFC_ISYM_EOSHIFT:
case GFC_ISYM_PACK:
case GFC_ISYM_UNPACK:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Attic/Makefile.am,v
retrieving revision 1.1.2.6
diff -u -r1.1.2.6 Makefile.am
--- libgfortran/Makefile.am 11 Oct 2003 19:28:11 -0000 1.1.2.6
+++ libgfortran/Makefile.am 12 Oct 2003 21:57:31 -0000
@@ -33,6 +33,7 @@
intrinsics/associated.c \
intrinsics/abort.c \
intrinsics/cpu_time.c \
+intrinsics/cshift0.c \
intrinsics/eoshift0.c \
intrinsics/eoshift2.c \
intrinsics/ishftc.c \
@@ -187,6 +188,10 @@
generated/eoshift3_4.c \
generated/eoshift3_8.c
+i_cshift1_c= \
+generated/cshift1_4.c \
+generated/cshift1_8.c
+
in_pack_c = \
generated/in_pack_i4.c \
generated/in_pack_i8.c
@@ -201,13 +206,13 @@
m4/dotprod.m4 m4/dotprodl.m4 m4/matmul.m4 m4/matmull.m4 \
m4/ctrig.m4 m4/cexp.m4 m4/chyp.m4 m4/mtype.m4 \
m4/specific.m4 m4/specific2.m4 m4/head.m4 m4/shape.m4 m4/reshape.m4 \
- m4/transpose.m4
+ m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4
gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
$(i_product_c) $(i_sum_c) $(i_dotprod_c) $(i_dotprodl_c) $(i_matmul_c) \
$(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
- $(i_eoshift3_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c)
+ $(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c)
# We only use these if libm doesn't contain complex math functions.
@@ -385,6 +390,9 @@
$(i_eoshift3_c): m4/eoshift3.m4 $(I_M4_DEPS)
m4 -Dfile=$@ -I$(srcdir)/m4 eoshift3.m4 > $@
+
+$(i_cshift1_c): m4/cshift1.m4 $(I_M4_DEPS)
+ m4 -Dfile=$@ -I$(srcdir)/m4 cshift1.m4 > $@
$(in_pack_c): m4/in_pack.m4 $(I_M4_DEPS)
m4 -Dfile=$@ -I$(srcdir)/m4 in_pack.m4 > $@
/* Generic implementation of the CSHIFT intrinsic
Copyright 2003 Free Software Foundation, Inc.
Contributed by Feng Wang <wf_cs@yahoo.com>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
Ligbfor 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 Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with libgfor; see the file COPYING.LIB. If not,
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>
#include "libgfortran.h"
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
__cshift0 (const gfc_array_char * ret, const gfc_array_char * array,
int shift, int which)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS - 1];
index_type rstride0;
index_type roffset;
char *rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS - 1];
index_type sstride0;
index_type soffset;
const char *sptr;
const char *src;
index_type count[GFC_MAX_DIMENSIONS - 1];
index_type extent[GFC_MAX_DIMENSIONS - 1];
index_type dim;
index_type size;
index_type len;
index_type n;
if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
size = GFC_DESCRIPTOR_SIZE (ret);
which = which - 1;
extent[0] = 1;
count[0] = 0;
size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* Initialized for avoiding compiler warnings. */
roffset = size;
soffset = size;
len = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = ret->dim[dim].stride * size;
if (roffset == 0)
roffset = size;
soffset = array->dim[dim].stride * size;
if (soffset == 0)
soffset = size;
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
}
else
{
count[n] = 0;
extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
n++;
}
}
if (sstride[0] == 0)
sstride[0] = size;
if (rstride[0] == 0)
rstride[0] = size;
dim = GFC_DESCRIPTOR_RANK (array);
rstride0 = rstride[0];
sstride0 = sstride[0];
rptr = ret->data;
sptr = array->data;
shift = (div (shift, len)).rem;
if (shift < 0)
shift += len;
while (rptr)
{
/* Do the shift for this dimension. */
src = &sptr[shift * soffset];
dest = rptr;
for (n = 0; n < len; n++)
{
memcpy (dest, src, size);
dest += roffset;
if (n == len - shift - 1)
src = sptr;
else
src += soffset;
}
/* Advance to the next section. */
rptr += rstride0;
sptr += sstride0;
count[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 proabably not worth it. */
rptr -= rstride[n] * extent[n];
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim - 1)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
sptr += sstride[n];
}
}
}
}
void
__cshift0_4 (const gfc_array_char * ret, const gfc_array_char * array,
const GFC_INTEGER_4 * pshift, const GFC_INTEGER_4 * pdim)
{
__cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
}
void
__cshift0_8 (const gfc_array_char * ret, const gfc_array_char * array,
const GFC_INTEGER_8 * pshift, const GFC_INTEGER_8 * pdim)
{
__cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
}
`/* Implementation of the CSHIFT intrinsic
Copyright 2003 Free Software Foundation, Inc.
Contributed by Feng Wang <wf_cs@yahoo.com>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
Ligbfor 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 Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with libgfor; see the file COPYING.LIB. If not,
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include <stdlib.h>
#include <assert.h>
#include <string.h>
#include "libgfortran.h"'
include(types.m4)dnl
define(htype_kind, regexp(file, `_\([0-9]+\)\.', `\1'))dnl
define(htype_code,`i'rtype_name)dnl
define(htype,get_arraytype(i,htype_kind))dnl
define(htype_name, get_typename(i,htype_kind))dnl
void
`__cshift1_'htype_kind (const gfc_array_char * ret, const gfc_array_char * array,
const htype * h, const htype_name * pwhich)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS - 1];
index_type rstride0;
index_type roffset;
char *rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS - 1];
index_type sstride0;
index_type soffset;
const char *sptr;
const char *src;
` /* h.* indicates the shift array. */'
index_type hstride[GFC_MAX_DIMENSIONS - 1];
index_type hstride0;
const htype_name *hptr;
index_type count[GFC_MAX_DIMENSIONS - 1];
index_type extent[GFC_MAX_DIMENSIONS - 1];
index_type dim;
index_type size;
index_type len;
index_type n;
int which;
htype_name sh;
if (pwhich)
which = *pwhich - 1;
else
which = 0;
if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
size = GFC_DESCRIPTOR_SIZE (ret);
extent[0] = 1;
count[0] = 0;
size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
`/* Initialized for avoiding compiler warnings. */'
roffset = size;
soffset = size;
len = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = ret->dim[dim].stride * size;
if (roffset == 0)
roffset = size;
soffset = array->dim[dim].stride * size;
if (soffset == 0)
soffset = size;
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
}
else
{
count[n] = 0;
extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
hstride[n] = h->dim[n].stride;
n++;
}
}
if (sstride[0] == 0)
sstride[0] = size;
if (rstride[0] == 0)
rstride[0] = size;
if (hstride[0] == 0)
hstride[0] = 1;
dim = GFC_DESCRIPTOR_RANK (array);
rstride0 = rstride[0];
sstride0 = sstride[0];
hstride0 = hstride[0];
rptr = ret->data;
sptr = array->data;
hptr = h->data;
while (rptr)
{
` /* Do the shift for this dimension. */'
sh = *hptr;
sh = (div (sh, len)).rem;
if (sh < 0)
sh += len;
src = &sptr[sh * soffset];
dest = rptr;
for (n = 0; n < len; n++)
{
memcpy (dest, src, size);
dest += roffset;
if (n == len - sh - 1)
src = sptr;
else
src += soffset;
}
/* Advance to the next section. */
rptr += rstride0;
sptr += sstride0;
hptr += hstride0;
count[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 proabably not worth it. */
rptr -= rstride[n] * extent[n];
sptr -= sstride[n] * extent[n];
hptr -= hstride[n] * extent[n];
n++;
if (n >= dim - 1)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
sptr += sstride[n];
hptr += hstride[n];
}
}
}
}