This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
PR 19269 (part 2): Define character versions of intrinsic array functions
- From: Richard Sandiford <richard at codesourcery dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: fortran at gcc dot gnu dot org
- Date: Sat, 10 Sep 2005 16:28:51 +0100
- Subject: PR 19269 (part 2): Define character versions of intrinsic array functions
As discussed earlier, this patch adds special character versions of
intrinsic array functions. I think the affected functions are:
cshift{0,1}
eoshift{0,1,2,3}
pack{,_s}
reshape
spread
transpose
unpack{0,1}
A lot of the patch is fairly mechanical, but there are a few
other changes too:
- gfc_resolve_unpack() only copied the type and kind from the
source vector, which left the result with a null charlen.
The patch makes it copy the whole typespec instead.
- gfc_conv_expr_descriptor has the following code to deal with
transformational functions:
if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
but the symbols associated with intrinsic functions don't even
have a charlen, never mind one with a backend_decl.
The patch for 15326 makes the length available in the function's
gfc_ss, so the patch copies it from there instead.
- The eoshift() functions used a zero buffer if no bound argument
was passed. We need to use blanks rather than zeros for characters,
and there's no longer a nice limit on the size of value we have
to copy, so I've changed the functions to use memset() instead.
- eoshift1_*() had:
hstride[n] = h->dim[n].stride * size;
but "size" is the size of source/result elements, not the size
of the shift values. We apply the stride to a pointer of type
"const atype_name *", so there's no need to scale the stride at all.
(Note that eoshift3_*() already got this right.)
- There was bug in pack()'s calculation of the array size. It had:
mptr += mstride[n];
This should be "m" (the mask iterator) not "mptr" (the pointer to
the start of the mask data).
I think associated() is the only other intrinsic (as opposed to
internal) function to take character arrays as arguments. I threw in a
test for that too, just for completeness. The patch doesn't need to do
anything to make the associated() test work though. The function really
is treated more like an internal function, and is only passed the two
arrays, even for characters:
args = NULL_TREE;
...
args = gfc_chainon_list (args, arg1se.expr);
...
args = gfc_chainon_list (args, arg2se.expr);
fndecl = gfor_fndecl_associated;
se->expr = gfc_build_function_call (fndecl, args);
Bootstrapped & regression tested on i686-pc-linux-gnu. OK to install?
Richard
gcc/fortran/
PR target/19269
* iresolve.c (gfc_resolve_cshift, gfc_resolve_eoshift)
(gfc_resolve_pack, gfc_resolve_reshape, gfc_resolve_spread)
(gfc_resolve_transpose, gfc_resolve_unpack): Add "_char" to the name
for character-based operations.
(gfc_resolve_pack): Remove ATTRIBUTE_UNUSED from array argument.
(gfc_resolve_unpack): Copy the whole typespec from the vector.
* trans-array.c (gfc_conv_expr_descriptor): In the EXPR_FUNCTION
case, get the string length from the scalarization state.
libgfortran/
PR target/19269
* intrinsics/cshift0.c (cshift0): Add an extra size argument.
(cshift0_1, cshift0_2, cshift0_4, cshift0_8): Replace explicit
implementations with...
(DEFINE_CSHIFT): ...this new macro. Define character versions too.
* intrinsics/eoshift0.c (zeros): Delete.
(eoshift0): Add extra size and filler arguments. Use memset if no
bound is provided.
(eoshift0_1, eoshift0_2, eoshift0_4, eoshift0_8): Replace explicit
implementations with...
(DEFINE_EOSHIFT): ...this new macro. Define character versions too.
* intrinsics/eoshift2.c (zeros): Delete.
(eoshift2): Add extra size and filler arguments. Use memset if no
bound is provided.
(eoshift2_1, eoshift2_2, eoshift2_4, eoshift2_8): Replace explicit
implementations with...
(DEFINE_EOSHIFT): ...this new macro. Define character versions too.
* intrinsics/pack.c (pack_internal): New static function, reusing
the contents of pack and adding an extra size argument. Change
"mptr" rather than "m" when calculating the array size.
(pack): Redefine as a forwarder to pack_internal.
(pack_s_internal): New static function, reusing the contents of
pack_s and adding an extra size argument.
(pack_s): Redefine as a forwarder to pack_s_internal.
(pack_char, pack_s_char): New functions.
* intrinsics/reshape.c (reshape_internal): New static function,
reusing the contents of reshape and adding an extra size argument.
(reshape): Redefine as a forwarder to reshape_internal.
(reshape_char): New function.
* intrinsics/spread.c (spread_internal): New static function,
reusing the contents of spread and adding an extra size argument.
(spread): Redefine as a forwarder to spread_internal.
(spread_char): New function.
* intrinsics/transpose.c (transpose_internal): New static function,
reusing the contents of transpose and adding an extra size argument.
(transpose): Redefine as a forwarder to transpose_internal.
(transpose_char): New function.
* intrinsics/unpack.c (unpack_internal): New static function, reusing
the contents of unpack1 and adding extra size and fsize arguments.
(unpack1): Redefine as a forwarder to unpack_internal.
(unpack0): Call unpack_internal instead of unpack1.
(unpack1_char, unpack0_char): New functions.
* m4/cshift1.m4 (cshift1): New static function, reusing the contents
of cshift1_<kind> and adding an extra size argument.
(cshift1_<kind>): Redefine as a forwarder to cshift1.
(cshift1_<kind>_char): New function.
* m4/eoshift1.m4 (zeros): Delete.
(eoshift1): New static function, reusing the contents of
eoshift1_<kind> and adding extra size and filler arguments.
Fix calculation of hstride. Use memset if no bound is provided.
(eoshift1_<kind>): Redefine as a forwarder to eoshift1.
(eoshift1_<kind>_char): New function.
* m4/eoshift3.m4 (zeros): Delete.
(eoshift3): New static function, reusing the contents of
eoshift3_<kind> and adding extra size and filler arguments.
Use memset if no bound is provided.
(eoshift3_<kind>): Redefine as a forwarder to eoshift3.
(eoshift3_<kind>_char): New function.
* generated/cshift1_4.c, generated/cshift1_8.c,
* generated/eoshift1_4.c, generated/eoshift1_8.c,
* generated/eoshift3_4.c, generated/eoshift3_8.c: Regenerate.
gcc/testsuite/
PR target/19269
* gfortran.dg/char_associated_1.f90, gfortran.dg/char_cshift_1.f90,
* gfortran.dg/char_cshift_2.f90, gfortran.dg/char_eoshift_1.f90,
* gfortran.dg/char_eoshift_2.f90, gfortran.dg/char_eoshift_3.f90,
* gfortran.dg/char_eoshift_4.f90, gfortran.dg/char_pack_1.f90,
* gfortran.dg/char_pack_2.f90, gfortran.dg/char_reshape_1.f90,
* gfortran.dg/char_spread_1.f90, gfortran.dg/char_transpoe_1.f90,
* gfortran.dg/char_unpack_1.f90, gfortran.dg/char_unpack_2.f90: New
tests.
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.38
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.38 iresolve.c
*** gcc/fortran/iresolve.c 10 Aug 2005 20:16:26 -0000 1.38
--- gcc/fortran/iresolve.c 10 Sep 2005 14:53:59 -0000
*************** gfc_resolve_cshift (gfc_expr * f, gfc_ex
*** 403,409 ****
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
! gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
}
--- 403,410 ----
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
! gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
! array->ts.type == BT_CHARACTER ? "_char" : "");
}
*************** gfc_resolve_eoshift (gfc_expr * f, gfc_e
*** 503,509 ****
}
f->value.function.name =
! gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
}
--- 504,511 ----
}
f->value.function.name =
! gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
! array->ts.type == BT_CHARACTER ? "_char" : "");
}
*************** gfc_resolve_not (gfc_expr * f, gfc_expr
*** 1083,1098 ****
void
! gfc_resolve_pack (gfc_expr * f,
! gfc_expr * array ATTRIBUTE_UNUSED,
! gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
! f->value.function.name = PREFIX("pack");
else
{
/* We convert mask to default logical only in the scalar case.
--- 1085,1100 ----
void
! gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
! f->value.function.name = (array->ts.type == BT_CHARACTER
! ? PREFIX("pack_char")
! : PREFIX("pack"));
else
{
/* We convert mask to default logical only in the scalar case.
*************** gfc_resolve_pack (gfc_expr * f,
*** 1107,1113 ****
gfc_convert_type (mask, &ts, 2);
}
! f->value.function.name = PREFIX("pack_s");
}
}
--- 1109,1117 ----
gfc_convert_type (mask, &ts, 2);
}
! f->value.function.name = (array->ts.type == BT_CHARACTER
! ? PREFIX("pack_s_char")
! : PREFIX("pack_s"));
}
}
*************** gfc_resolve_reshape (gfc_expr * f, gfc_e
*** 1214,1220 ****
break;
default:
! f->value.function.name = PREFIX("reshape");
break;
}
--- 1218,1226 ----
break;
default:
! f->value.function.name = (source->ts.type == BT_CHARACTER
! ? PREFIX("reshape_char")
! : PREFIX("reshape"));
break;
}
*************** gfc_resolve_spread (gfc_expr * f, gfc_ex
*** 1362,1368 ****
{
f->ts = source->ts;
f->rank = source->rank + 1;
! f->value.function.name = PREFIX("spread");
gfc_resolve_dim_arg (dim);
gfc_resolve_index (ncopies, 1);
--- 1368,1376 ----
{
f->ts = source->ts;
f->rank = source->rank + 1;
! f->value.function.name = (source->ts.type == BT_CHARACTER
! ? PREFIX("spread_char")
! : PREFIX("spread"));
gfc_resolve_dim_arg (dim);
gfc_resolve_index (ncopies, 1);
*************** gfc_resolve_transpose (gfc_expr * f, gfc
*** 1542,1548 ****
break;
default:
! f->value.function.name = PREFIX("transpose");
}
}
--- 1550,1559 ----
break;
default:
! f->value.function.name = (matrix->ts.type == BT_CHARACTER
! ? PREFIX("transpose_char")
! : PREFIX("transpose"));
! break;
}
}
*************** void
*** 1601,1612 ****
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
{
! f->ts.type = vector->ts.type;
! f->ts.kind = vector->ts.kind;
f->rank = mask->rank;
f->value.function.name =
! gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
}
--- 1612,1623 ----
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
{
! f->ts = vector->ts;
f->rank = mask->rank;
f->value.function.name =
! gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
! vector->ts.type == BT_CHARACTER ? "_char" : "");
}
Index: gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.60
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.60 trans-array.c
*** gcc/fortran/trans-array.c 9 Sep 2005 06:34:07 -0000 1.60
--- gcc/fortran/trans-array.c 10 Sep 2005 14:54:00 -0000
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3883,3891 ****
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
!
! if (expr->ts.type == BT_CHARACTER)
! se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
}
else
{
--- 3883,3889 ----
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
! se->string_length = ss->string_length;
}
else
{
Index: libgfortran/intrinsics/cshift0.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/cshift0.c,v
retrieving revision 1.13
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.13 cshift0.c
*** libgfortran/intrinsics/cshift0.c 17 Aug 2005 02:48:51 -0000 1.13
--- libgfortran/intrinsics/cshift0.c 10 Sep 2005 14:54:00 -0000
*************** DEF_COPY_LOOP(cdouble, _Complex double)
*** 78,84 ****
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
! ssize_t shift, int which)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 78,84 ----
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
! ssize_t shift, int which, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** cshift0 (gfc_array_char * ret, const gfc
*** 95,101 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int whichloop;
--- 95,100 ----
*************** cshift0 (gfc_array_char * ret, const gfc
*** 107,113 ****
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* The values assigned here must match the cases in the inner loop. */
--- 106,111 ----
*************** cshift0 (gfc_array_char * ret, const gfc
*** 298,348 ****
}
}
!
! extern void cshift0_1 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_1 *, const GFC_INTEGER_1 *);
! export_proto(cshift0_1);
!
! void
! cshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_1 *pshift, const GFC_INTEGER_1 *pdim)
! {
! cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
! }
!
!
! extern void cshift0_2 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_2 *, const GFC_INTEGER_2 *);
! export_proto(cshift0_2);
!
! void
! cshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_2 *pshift, const GFC_INTEGER_2 *pdim)
! {
! cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
! }
!
!
! extern void cshift0_4 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_4 *, const GFC_INTEGER_4 *);
! export_proto(cshift0_4);
!
! void
! cshift0_4 (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);
! }
!
!
! extern void cshift0_8 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_8 *, const GFC_INTEGER_8 *);
! export_proto(cshift0_8);
!
! void
! cshift0_8 (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);
! }
!
--- 296,332 ----
}
}
! #define DEFINE_CSHIFT(N) \
! extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
! const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
! export_proto(cshift0_##N); \
! \
! void \
! cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
! { \
! cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
! GFC_DESCRIPTOR_SIZE (array)); \
! } \
! \
! extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
! const gfc_array_char *, \
! const GFC_INTEGER_##N *, \
! const GFC_INTEGER_##N *, GFC_INTEGER_4); \
! export_proto(cshift0_##N##_char); \
! \
! void \
! cshift0_##N##_char (gfc_array_char *ret, \
! GFC_INTEGER_4 ret_length __attribute__((unused)), \
! const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, \
! const GFC_INTEGER_##N *pdim, \
! GFC_INTEGER_4 array_length) \
! { \
! cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
! }
!
! DEFINE_CSHIFT (1);
! DEFINE_CSHIFT (2);
! DEFINE_CSHIFT (4);
! DEFINE_CSHIFT (8);
Index: libgfortran/intrinsics/eoshift0.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/eoshift0.c,v
retrieving revision 1.16
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.16 eoshift0.c
*** libgfortran/intrinsics/eoshift0.c 17 Aug 2005 02:48:52 -0000 1.16
--- libgfortran/intrinsics/eoshift0.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 34,48 ****
#include <string.h>
#include "libgfortran.h"
- static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
! int shift, const char * pbound, int which)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 34,46 ----
#include <string.h>
#include "libgfortran.h"
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
! int shift, const char * pbound, int which, index_type size,
! char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** eoshift0 (gfc_array_char * ret, const gf
*** 60,66 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
--- 58,63 ----
*************** eoshift0 (gfc_array_char * ret, const gf
*** 70,80 ****
soffset = 0;
roffset = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
--- 67,72 ----
*************** eoshift0 (gfc_array_char * ret, const gf
*** 98,104 ****
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
--- 90,95 ----
*************** eoshift0 (gfc_array_char * ret, const gf
*** 174,184 ****
n = -shift;
}
! while (n--)
! {
! memcpy (dest, pbound, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
--- 165,182 ----
n = -shift;
}
! if (pbound)
! while (n--)
! {
! memcpy (dest, pbound, size);
! dest += roffset;
! }
! else
! while (n--)
! {
! memset (dest, filler, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
*************** eoshift0 (gfc_array_char * ret, const gf
*** 212,268 ****
}
! extern void eoshift0_1 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_1 *, const char *,
! const GFC_INTEGER_1 *);
! export_proto(eoshift0_1);
!
! void
! eoshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_1 *pshift, const char *pbound,
! const GFC_INTEGER_1 *pdim)
! {
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift0_2 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_2 *, const char *,
! const GFC_INTEGER_2 *);
! export_proto(eoshift0_2);
!
! void
! eoshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_2 *pshift, const char *pbound,
! const GFC_INTEGER_2 *pdim)
! {
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift0_4 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_4 *, const char *,
! const GFC_INTEGER_4 *);
! export_proto(eoshift0_4);
!
! void
! eoshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_4 *pshift, const char *pbound,
! const GFC_INTEGER_4 *pdim)
! {
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift0_8 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_8 *, const char *,
! const GFC_INTEGER_8 *);
! export_proto(eoshift0_8);
!
! void
! eoshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_8 *pshift, const char *pbound,
! const GFC_INTEGER_8 *pdim)
! {
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
! }
--- 210,252 ----
}
! #define DEFINE_EOSHIFT(N) \
! extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *, \
! const GFC_INTEGER_##N *, const char *, \
! const GFC_INTEGER_##N *); \
! export_proto(eoshift0_##N); \
! \
! void \
! eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, const char *pbound, \
! const GFC_INTEGER_##N *pdim) \
! { \
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
! GFC_DESCRIPTOR_SIZE (array), 0); \
! } \
! \
! extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
! const gfc_array_char *, \
! const GFC_INTEGER_##N *, const char *, \
! const GFC_INTEGER_##N *, GFC_INTEGER_4, \
! GFC_INTEGER_4); \
! export_proto(eoshift0_##N##_char); \
! \
! void \
! eoshift0_##N##_char (gfc_array_char *ret, \
! GFC_INTEGER_4 ret_length __attribute__((unused)), \
! const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, \
! const char *pbound, \
! const GFC_INTEGER_##N *pdim, \
! GFC_INTEGER_4 array_length, \
! GFC_INTEGER_4 bound_length __attribute__((unused))) \
! { \
! eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
! array_length, ' '); \
! }
!
! DEFINE_EOSHIFT (1);
! DEFINE_EOSHIFT (2);
! DEFINE_EOSHIFT (4);
! DEFINE_EOSHIFT (8);
Index: libgfortran/intrinsics/eoshift2.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/eoshift2.c,v
retrieving revision 1.16
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.16 eoshift2.c
*** libgfortran/intrinsics/eoshift2.c 17 Aug 2005 02:48:52 -0000 1.16
--- libgfortran/intrinsics/eoshift2.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 34,48 ****
#include <string.h>
#include "libgfortran.h"
- static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
! int shift, const gfc_array_char *bound, int which)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 34,46 ----
#include <string.h>
#include "libgfortran.h"
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
! int shift, const gfc_array_char *bound, int which,
! index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 64,70 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
--- 62,67 ----
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 74,81 ****
soffset = 0;
roffset = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
--- 71,76 ----
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 99,105 ****
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
--- 94,99 ----
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 156,162 ****
if (bound)
bptr = bound->data;
else
! bptr = zeros;
while (rptr)
{
--- 150,156 ----
if (bound)
bptr = bound->data;
else
! bptr = NULL;
while (rptr)
{
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 187,197 ****
n = -shift;
}
! while (n--)
! {
! memcpy (dest, bptr, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
--- 181,198 ----
n = -shift;
}
! if (bptr)
! while (n--)
! {
! memcpy (dest, bptr, size);
! dest += roffset;
! }
! else
! while (n--)
! {
! memset (dest, filler, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
*************** eoshift2 (gfc_array_char *ret, const gfc
*** 228,284 ****
}
! extern void eoshift2_1 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_1 *, const gfc_array_char *,
! const GFC_INTEGER_1 *);
! export_proto(eoshift2_1);
!
! void
! eoshift2_1 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_1 *pshift, const gfc_array_char *bound,
! const GFC_INTEGER_1 *pdim)
! {
! eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift2_2 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_2 *, const gfc_array_char *,
! const GFC_INTEGER_2 *);
! export_proto(eoshift2_2);
!
! void
! eoshift2_2 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_2 *pshift, const gfc_array_char *bound,
! const GFC_INTEGER_2 *pdim)
! {
! eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift2_4 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_4 *, const gfc_array_char *,
! const GFC_INTEGER_4 *);
! export_proto(eoshift2_4);
!
! void
! eoshift2_4 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_4 *pshift, const gfc_array_char *bound,
! const GFC_INTEGER_4 *pdim)
! {
! eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
! }
!
!
! extern void eoshift2_8 (gfc_array_char *, const gfc_array_char *,
! const GFC_INTEGER_8 *, const gfc_array_char *,
! const GFC_INTEGER_8 *);
! export_proto(eoshift2_8);
!
! void
! eoshift2_8 (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_INTEGER_8 *pshift, const gfc_array_char *bound,
! const GFC_INTEGER_8 *pdim)
! {
! eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
! }
--- 229,272 ----
}
! #define DEFINE_EOSHIFT(N) \
! extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *, \
! const GFC_INTEGER_##N *, const gfc_array_char *, \
! const GFC_INTEGER_##N *); \
! export_proto(eoshift2_##N); \
! \
! void \
! eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound, \
! const GFC_INTEGER_##N *pdim) \
! { \
! eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
! GFC_DESCRIPTOR_SIZE (array), 0); \
! } \
! \
! extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
! const gfc_array_char *, \
! const GFC_INTEGER_##N *, \
! const gfc_array_char *, \
! const GFC_INTEGER_##N *, \
! GFC_INTEGER_4, GFC_INTEGER_4); \
! export_proto(eoshift2_##N##_char); \
! \
! void \
! eoshift2_##N##_char (gfc_array_char *ret, \
! GFC_INTEGER_4 ret_length __attribute__((unused)), \
! const gfc_array_char *array, \
! const GFC_INTEGER_##N *pshift, \
! const gfc_array_char *pbound, \
! const GFC_INTEGER_##N *pdim, \
! GFC_INTEGER_4 array_length, \
! GFC_INTEGER_4 bound_length __attribute__((unused))) \
! { \
! eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
! array_length, ' '); \
! }
!
! DEFINE_EOSHIFT (1);
! DEFINE_EOSHIFT (2);
! DEFINE_EOSHIFT (4);
! DEFINE_EOSHIFT (8);
Index: libgfortran/intrinsics/pack_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/pack_generic.c,v
retrieving revision 1.11
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.11 pack_generic.c
*** libgfortran/intrinsics/pack_generic.c 17 Aug 2005 02:48:53 -0000 1.11
--- libgfortran/intrinsics/pack_generic.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 74,86 ****
There are two variants of the PACK intrinsic: one, where MASK is
array valued, and the other one where MASK is scalar. */
! extern void pack (gfc_array_char *, const gfc_array_char *,
! const gfc_array_l4 *, const gfc_array_char *);
! export_proto(pack);
!
! void
! pack (gfc_array_char *ret, const gfc_array_char *array,
! const gfc_array_l4 *mask, const gfc_array_char *vector)
{
/* r.* indicates the return array. */
index_type rstride0;
--- 74,83 ----
There are two variants of the PACK intrinsic: one, where MASK is
array valued, and the other one where MASK is scalar. */
! static void
! pack_internal (gfc_array_char *ret, const gfc_array_char *array,
! const gfc_array_l4 *mask, const gfc_array_char *vector,
! index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
*************** pack (gfc_array_char *ret, const gfc_arr
*** 98,107 ****
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type nelem;
- size = GFC_DESCRIPTOR_SIZE (array);
dim = GFC_DESCRIPTOR_RANK (array);
for (n = 0; n < dim; n++)
{
--- 95,102 ----
*************** pack (gfc_array_char *ret, const gfc_arr
*** 189,195 ****
else
{
count[n]++;
! mptr += mstride[n];
}
}
}
--- 184,190 ----
else
{
count[n]++;
! m += mstride[n];
}
}
}
*************** pack (gfc_array_char *ret, const gfc_arr
*** 277,289 ****
}
}
! extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_LOGICAL_4 *, const gfc_array_char *);
! export_proto(pack_s);
void
! pack_s (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
{
/* r.* indicates the return array. */
index_type rstride0;
--- 272,307 ----
}
}
! extern void pack (gfc_array_char *, const gfc_array_char *,
! const gfc_array_l4 *, const gfc_array_char *);
! export_proto(pack);
void
! pack (gfc_array_char *ret, const gfc_array_char *array,
! const gfc_array_l4 *mask, const gfc_array_char *vector)
! {
! pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
! }
!
! extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
! const gfc_array_l4 *, const gfc_array_char *,
! GFC_INTEGER_4, GFC_INTEGER_4);
! export_proto(pack_char);
!
! void
! pack_char (gfc_array_char *ret,
! GFC_INTEGER_4 ret_length __attribute__((unused)),
! const gfc_array_char *array, const gfc_array_l4 *mask,
! const gfc_array_char *vector, GFC_INTEGER_4 array_length,
! GFC_INTEGER_4 vector_length __attribute__((unused)))
! {
! pack_internal (ret, array, mask, vector, array_length);
! }
!
! static void
! pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
! const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
! index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
*************** pack_s (gfc_array_char *ret, const gfc_a
*** 297,306 ****
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type nelem;
- size = GFC_DESCRIPTOR_SIZE (array);
dim = GFC_DESCRIPTOR_RANK (array);
for (n = 0; n < dim; n++)
{
--- 315,322 ----
*************** pack_s (gfc_array_char *ret, const gfc_a
*** 426,428 ****
--- 442,471 ----
}
}
}
+
+ extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
+ const GFC_LOGICAL_4 *, const gfc_array_char *);
+ export_proto(pack_s);
+
+ void
+ pack_s (gfc_array_char *ret, const gfc_array_char *array,
+ const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
+ {
+ pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
+ }
+
+ extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
+ const gfc_array_char *array, const GFC_LOGICAL_4 *,
+ const gfc_array_char *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+ export_proto(pack_s_char);
+
+ void
+ pack_s_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
+ const gfc_array_char *vector, GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 vector_length __attribute__((unused)))
+ {
+ pack_s_internal (ret, array, mask, vector, array_length);
+ }
Index: libgfortran/intrinsics/reshape_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/reshape_generic.c,v
retrieving revision 1.10
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.10 reshape_generic.c
*** libgfortran/intrinsics/reshape_generic.c 17 Aug 2005 02:48:54 -0000 1.10
--- libgfortran/intrinsics/reshape_generic.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 37,51 ****
typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
- extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
- export_proto(reshape);
-
/* The shape parameter is ignored. We can currently deduce the shape from the
return array. */
! void
! reshape (parray *ret, parray *source, shape_type *shape,
! parray *pad, shape_type *order)
{
/* r.* indicates the return array. */
index_type rcount[GFC_MAX_DIMENSIONS];
--- 37,48 ----
typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
/* The shape parameter is ignored. We can currently deduce the shape from the
return array. */
! static void
! reshape_internal (parray *ret, parray *source, shape_type *shape,
! parray *pad, shape_type *order, index_type size)
{
/* r.* indicates the return array. */
index_type rcount[GFC_MAX_DIMENSIONS];
*************** reshape (parray *ret, parray *source, sh
*** 76,82 ****
const char *src;
int n;
int dim;
- int size;
if (source->dim[0].stride == 0)
source->dim[0].stride = 1;
--- 73,78 ----
*************** reshape (parray *ret, parray *source, sh
*** 89,95 ****
if (ret->data == NULL)
{
- size = GFC_DESCRIPTOR_SIZE (ret);
rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
rs = 1;
for (n=0; n < rdim; n++)
--- 85,90 ----
*************** reshape (parray *ret, parray *source, sh
*** 106,112 ****
}
else
{
- size = GFC_DESCRIPTOR_SIZE (ret);
rdim = GFC_DESCRIPTOR_RANK (ret);
if (ret->dim[0].stride == 0)
ret->dim[0].stride = 1;
--- 101,106 ----
*************** reshape (parray *ret, parray *source, sh
*** 260,262 ****
--- 254,281 ----
}
}
}
+
+ extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
+ export_proto(reshape);
+
+ void
+ reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
+ shape_type *order)
+ {
+ reshape_internal (ret, source, shape, pad, order,
+ GFC_DESCRIPTOR_SIZE (source));
+ }
+
+ extern void reshape_char (parray *, GFC_INTEGER_4, parray *, shape_type *,
+ parray *, shape_type *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+ export_proto(reshape_char);
+
+ void
+ reshape_char (parray *ret, GFC_INTEGER_4 ret_length __attribute__((unused)),
+ parray *source, shape_type *shape, parray *pad,
+ shape_type *order, GFC_INTEGER_4 source_length,
+ GFC_INTEGER_4 pad_length __attribute__((unused)))
+ {
+ reshape_internal (ret, source, shape, pad, order, source_length);
+ }
Index: libgfortran/intrinsics/spread_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/spread_generic.c,v
retrieving revision 1.11
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.11 spread_generic.c
*** libgfortran/intrinsics/spread_generic.c 17 Aug 2005 02:48:54 -0000 1.11
--- libgfortran/intrinsics/spread_generic.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 34,46 ****
#include <string.h>
#include "libgfortran.h"
! extern void spread (gfc_array_char *, const gfc_array_char *,
! const index_type *, const index_type *);
! export_proto(spread);
!
! void
! spread (gfc_array_char *ret, const gfc_array_char *source,
! const index_type *along, const index_type *pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 34,43 ----
#include <string.h>
#include "libgfortran.h"
! static void
! spread_internal (gfc_array_char *ret, const gfc_array_char *source,
! const index_type *along, const index_type *pncopies,
! index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** spread (gfc_array_char *ret, const gfc_a
*** 60,66 ****
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
--- 57,62 ----
*************** spread (gfc_array_char *ret, const gfc_a
*** 74,80 ****
ncopies = *pncopies;
- size = GFC_DESCRIPTOR_SIZE (source);
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
--- 70,75 ----
*************** spread (gfc_array_char *ret, const gfc_a
*** 180,182 ****
--- 175,202 ----
}
}
}
+
+ extern void spread (gfc_array_char *, const gfc_array_char *,
+ const index_type *, const index_type *);
+ export_proto(spread);
+
+ void
+ spread (gfc_array_char *ret, const gfc_array_char *source,
+ const index_type *along, const index_type *pncopies)
+ {
+ spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
+ }
+
+ extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const index_type *,
+ const index_type *, GFC_INTEGER_4);
+ export_proto(spread_char);
+
+ void
+ spread_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *source, const index_type *along,
+ const index_type *pncopies, GFC_INTEGER_4 source_length)
+ {
+ spread_internal (ret, source, along, pncopies, source_length);
+ }
Index: libgfortran/intrinsics/transpose_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/transpose_generic.c,v
retrieving revision 1.10
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.10 transpose_generic.c
*** libgfortran/intrinsics/transpose_generic.c 17 Aug 2005 02:48:54 -0000 1.10
--- libgfortran/intrinsics/transpose_generic.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 37,44 ****
extern void transpose (gfc_array_char *, gfc_array_char *);
export_proto(transpose);
! void
! transpose (gfc_array_char *ret, gfc_array_char *source)
{
/* r.* indicates the return array. */
index_type rxstride, rystride;
--- 37,45 ----
extern void transpose (gfc_array_char *, gfc_array_char *);
export_proto(transpose);
! static void
! transpose_internal (gfc_array_char *ret, gfc_array_char *source,
! index_type size)
{
/* r.* indicates the return array. */
index_type rxstride, rystride;
*************** transpose (gfc_array_char *ret, gfc_arra
*** 49,61 ****
index_type xcount, ycount;
index_type x, y;
- index_type size;
assert (GFC_DESCRIPTOR_RANK (source) == 2
&& GFC_DESCRIPTOR_RANK (ret) == 2);
- size = GFC_DESCRIPTOR_SIZE (source);
-
if (ret->data == NULL)
{
assert (ret->dtype == source->dtype);
--- 50,59 ----
*************** transpose (gfc_array_char *ret, gfc_arra
*** 100,102 ****
--- 98,121 ----
rptr += rxstride - (rystride * xcount);
}
}
+
+ extern void transpose (gfc_array_char *, gfc_array_char *);
+ export_proto(transpose);
+
+ void
+ transpose (gfc_array_char *ret, gfc_array_char *source)
+ {
+ transpose_internal (ret, source, GFC_DESCRIPTOR_SIZE (source));
+ }
+
+ extern void transpose_char (gfc_array_char *, GFC_INTEGER_4,
+ gfc_array_char *, GFC_INTEGER_4);
+ export_proto(transpose_char);
+
+ void
+ transpose_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ gfc_array_char *source, GFC_INTEGER_4 source_length)
+ {
+ transpose_internal (ret, source, source_length);
+ }
Index: libgfortran/intrinsics/unpack_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/unpack_generic.c,v
retrieving revision 1.10
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.10 unpack_generic.c
*** libgfortran/intrinsics/unpack_generic.c 17 Aug 2005 02:48:55 -0000 1.10
--- libgfortran/intrinsics/unpack_generic.c 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 34,46 ****
#include <string.h>
#include "libgfortran.h"
! extern void unpack1 (gfc_array_char *, const gfc_array_char *,
! const gfc_array_l4 *, const gfc_array_char *);
! iexport_proto(unpack1);
!
! void
! unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
! const gfc_array_l4 *mask, const gfc_array_char *field)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 34,43 ----
#include <string.h>
#include "libgfortran.h"
! static void
! unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
! const gfc_array_l4 *mask, const gfc_array_char *field,
! index_type size, index_type fsize)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** unpack1 (gfc_array_char *ret, const gfc_
*** 63,74 ****
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
- index_type fsize;
- size = GFC_DESCRIPTOR_SIZE (ret);
- /* A field element size of 0 actually means this is a scalar. */
- fsize = GFC_DESCRIPTOR_SIZE (field);
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
--- 60,66 ----
*************** unpack1 (gfc_array_char *ret, const gfc_
*** 177,183 ****
}
}
}
! iexport(unpack1);
extern void unpack0 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l4 *, char *);
--- 169,203 ----
}
}
}
!
! extern void unpack1 (gfc_array_char *, const gfc_array_char *,
! const gfc_array_l4 *, const gfc_array_char *);
! export_proto(unpack1);
!
! void
! unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
! const gfc_array_l4 *mask, const gfc_array_char *field)
! {
! unpack_internal (ret, vector, mask, field,
! GFC_DESCRIPTOR_SIZE (vector),
! GFC_DESCRIPTOR_SIZE (field));
! }
!
! extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
! const gfc_array_char *, const gfc_array_l4 *,
! const gfc_array_char *, GFC_INTEGER_4,
! GFC_INTEGER_4);
! export_proto(unpack1_char);
!
! void
! unpack1_char (gfc_array_char *ret,
! GFC_INTEGER_4 ret_length __attribute__((unused)),
! const gfc_array_char *vector, const gfc_array_l4 *mask,
! const gfc_array_char *field, GFC_INTEGER_4 vector_length,
! GFC_INTEGER_4 field_length)
! {
! unpack_internal (ret, vector, mask, field, vector_length, field_length);
! }
extern void unpack0 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l4 *, char *);
*************** unpack0 (gfc_array_char *ret, const gfc_
*** 191,195 ****
tmp.dtype = 0;
tmp.data = field;
! unpack1 (ret, vector, mask, &tmp);
}
--- 211,234 ----
tmp.dtype = 0;
tmp.data = field;
! unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
! }
!
! extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
! const gfc_array_char *, const gfc_array_l4 *,
! char *, GFC_INTEGER_4, GFC_INTEGER_4);
! export_proto(unpack0_char);
!
! void
! unpack0_char (gfc_array_char *ret,
! GFC_INTEGER_4 ret_length __attribute__((unused)),
! const gfc_array_char *vector, const gfc_array_l4 *mask,
! char *field, GFC_INTEGER_4 vector_length,
! GFC_INTEGER_4 field_length __attribute__((unused)))
! {
! gfc_array_char tmp;
!
! tmp.dtype = 0;
! tmp.data = field;
! unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
}
Index: libgfortran/m4/cshift1.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/cshift1.m4,v
retrieving revision 1.10
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.10 cshift1.m4
*** libgfortran/m4/cshift1.m4 17 Aug 2005 02:49:04 -0000 1.10
--- libgfortran/m4/cshift1.m4 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 35,49 ****
#include "libgfortran.h"'
include(iparm.m4)dnl
! void cshift1_`'atype_kind (gfc_array_char * ret,
! const gfc_array_char * array,
! const atype * h, const atype_name * pwhich);
! export_proto(cshift1_`'atype_kind);
!
! void
! cshift1_`'atype_kind (gfc_array_char * ret,
! const gfc_array_char * array,
! const atype * h, const atype_name * pwhich)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 35,43 ----
#include "libgfortran.h"'
include(iparm.m4)dnl
! static void
! cshift1 (gfc_array_char * ret, const gfc_array_char * array,
! const atype * h, const atype_name * pwhich, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** cshift1_`'atype_kind (gfc_array_char * r
*** 65,71 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
--- 59,64 ----
*************** cshift1_`'atype_kind (gfc_array_char * r
*** 79,86 ****
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);
-
if (ret->data == NULL)
{
int i;
--- 72,77 ----
*************** cshift1_`'atype_kind (gfc_array_char * r
*** 102,108 ****
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* Initialized for avoiding compiler warnings. */
--- 93,98 ----
*************** cshift1_`'atype_kind (gfc_array_char * r
*** 202,204 ****
--- 192,222 ----
}
}
}
+
+ void cshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const atype_name *);
+ export_proto(cshift1_`'atype_kind);
+
+ void
+ cshift1_`'atype_kind (gfc_array_char * ret,
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich)
+ {
+ cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array));
+ }
+
+ void cshift1_`'atype_kind`'_char (gfc_array_char * ret, GFC_INTEGER_4,
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich,
+ GFC_INTEGER_4);
+ export_proto(cshift1_`'atype_kind`'_char);
+
+ void
+ cshift1_`'atype_kind`'_char (gfc_array_char * ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich,
+ GFC_INTEGER_4 array_length)
+ {
+ cshift1 (ret, array, h, pwhich, array_length);
+ }
Index: libgfortran/m4/eoshift1.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/eoshift1.m4,v
retrieving revision 1.13
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.13 eoshift1.m4
*** libgfortran/m4/eoshift1.m4 17 Aug 2005 02:49:04 -0000 1.13
--- libgfortran/m4/eoshift1.m4 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 35,54 ****
#include "libgfortran.h"'
include(iparm.m4)dnl
! static const char zeros[16] =
! {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
!
! extern void eoshift1_`'atype_kind (gfc_array_char *,
! const gfc_array_char *,
! const atype *, const char *,
! const atype_name *);
! export_proto(eoshift1_`'atype_kind);
!
! void
! eoshift1_`'atype_kind (gfc_array_char *ret,
! const gfc_array_char *array,
! const atype *h, const char *pbound,
! const atype_name *pwhich)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 35,44 ----
#include "libgfortran.h"'
include(iparm.m4)dnl
! static void
! eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
! const char *pbound, const atype_name *pwhich, index_type size,
! char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** eoshift1_`'atype_kind (gfc_array_char *r
*** 70,76 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
--- 60,65 ----
*************** eoshift1_`'atype_kind (gfc_array_char *r
*** 88,101 ****
else
which = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
if (ret->data == NULL)
{
--- 77,84 ----
*************** eoshift1_`'atype_kind (gfc_array_char *r
*** 136,142 ****
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
! hstride[n] = h->dim[n].stride * size;
n++;
}
}
--- 119,125 ----
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
! hstride[n] = h->dim[n].stride;
n++;
}
}
*************** eoshift1_`'atype_kind (gfc_array_char *r
*** 187,197 ****
dest = rptr;
n = delta;
! while (n--)
! {
! memcpy (dest, pbound, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
--- 170,187 ----
dest = rptr;
n = delta;
! if (pbound)
! while (n--)
! {
! memcpy (dest, pbound, size);
! dest += roffset;
! }
! else
! while (n--)
! {
! memset (dest, filler, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
*************** eoshift1_`'atype_kind (gfc_array_char *r
*** 226,228 ****
--- 216,248 ----
}
}
}
+
+ void eoshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const char *, const atype_name *);
+ export_proto(eoshift1_`'atype_kind);
+
+ void
+ eoshift1_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
+ const atype *h, const char *pbound,
+ const atype_name *pwhich)
+ {
+ eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+ }
+
+ void eoshift1_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const atype *,
+ const char *, const atype_name *,
+ GFC_INTEGER_4, GFC_INTEGER_4);
+ export_proto(eoshift1_`'atype_kind`'_char);
+
+ void
+ eoshift1_`'atype_kind`'_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const atype *h,
+ const char *pbound, const atype_name *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+ {
+ eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
+ }
Index: libgfortran/m4/eoshift3.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/eoshift3.m4,v
retrieving revision 1.13
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -r1.13 eoshift3.m4
*** libgfortran/m4/eoshift3.m4 17 Aug 2005 02:49:04 -0000 1.13
--- libgfortran/m4/eoshift3.m4 10 Sep 2005 14:54:00 -0000
*************** Boston, MA 02110-1301, USA. */
*** 35,52 ****
#include "libgfortran.h"'
include(iparm.m4)dnl
! static const char zeros[16] =
! {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
!
! extern void eoshift3_`'atype_kind (gfc_array_char *, gfc_array_char *,
! atype *, const gfc_array_char *,
! atype_name *);
! export_proto(eoshift3_`'atype_kind);
!
! void
! eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array,
! atype *h, const gfc_array_char *bound,
! atype_name *pwhich)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
--- 35,44 ----
#include "libgfortran.h"'
include(iparm.m4)dnl
! static void
! eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
! const gfc_array_char *bound, const atype_name *pwhich,
! index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 72,78 ****
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
--- 64,69 ----
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 90,96 ****
else
which = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
if (ret->data == NULL)
{
int i;
--- 81,86 ----
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 113,119 ****
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
--- 103,108 ----
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 162,168 ****
if (bound)
bptr = bound->data;
else
! bptr = zeros;
while (rptr)
{
--- 151,157 ----
if (bound)
bptr = bound->data;
else
! bptr = NULL;
while (rptr)
{
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 196,206 ****
dest = rptr;
n = delta;
! while (n--)
! {
! memcpy (dest, bptr, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
--- 185,202 ----
dest = rptr;
n = delta;
! if (bptr)
! while (n--)
! {
! memcpy (dest, bptr, size);
! dest += roffset;
! }
! else
! while (n--)
! {
! memset (dest, filler, size);
! dest += roffset;
! }
/* Advance to the next section. */
rptr += rstride0;
*************** eoshift3_`'atype_kind (gfc_array_char *r
*** 238,240 ****
--- 234,270 ----
}
}
}
+
+ extern void eoshift3_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const gfc_array_char *,
+ const atype_name *);
+ export_proto(eoshift3_`'atype_kind);
+
+ void
+ eoshift3_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
+ const atype *h, const gfc_array_char *bound,
+ const atype_name *pwhich)
+ {
+ eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+ }
+
+ extern void eoshift3_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *,
+ const atype *,
+ const gfc_array_char *,
+ const atype_name *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+ export_proto(eoshift3_`'atype_kind`'_char);
+
+ void
+ eoshift3_`'atype_kind`'_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const atype *h,
+ const gfc_array_char *bound,
+ const atype_name *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+ {
+ eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
+ }
diff -c /dev/null gcc/testsuite/gfortran.dg/char_associated_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_associated_1.f90 2005-09-09 16:53:07.000000000 +0100
***************
*** 0 ****
--- 1,8 ----
+ ! Check that associated works correctly for character arrays.
+ ! { dg-do run }
+ program main
+ character (len = 5), dimension (:), pointer :: ptr
+ character (len = 5), dimension (2), target :: a = (/ 'abcde', 'fghij' /)
+ ptr => a
+ if (.not. associated (ptr, a)) call abort
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_cshift_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_cshift_1.f90 2005-09-09 18:00:37.000000000 +0100
***************
*** 0 ****
--- 1,40 ----
+ ! Test cshift0 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ integer (kind = 1) :: shift1 = 3
+ integer (kind = 2) :: shift2 = 4
+ integer (kind = 4) :: shift3 = 5
+ integer (kind = 8) :: shift4 = 6
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (cshift (a, shift1, 1), int (shift1), 0, 0)
+ call test (cshift (a, shift2, 2), 0, int (shift2), 0)
+ call test (cshift (a, shift3, 3), 0, 0, int (shift3))
+ call test (cshift (a, shift4, 3), 0, 0, int (shift4))
+ contains
+ subroutine test (b, d1, d2, d3)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ integer :: d1, d2, d3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i1, i2, i3) .ne. a (mod (d1 + i1 - 1, n1) + 1, &
+ mod (d2 + i2 - 1, n2) + 1, &
+ mod (d3 + i3 - 1, n3) + 1)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_cshift_2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_cshift_2.f90 2005-09-09 18:00:57.000000000 +0100
***************
*** 0 ****
--- 1,45 ----
+ ! Test cshift1 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ integer (kind = 1), dimension (2, 4) :: shift1
+ integer (kind = 2), dimension (2, 4) :: shift2
+ integer (kind = 4), dimension (2, 4) :: shift3
+ integer (kind = 8), dimension (2, 4) :: shift4
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
+ end do
+ end do
+ end do
+
+ shift1 (1, :) = (/ 4, 11, 19, 20 /)
+ shift1 (2, :) = (/ 55, 5, 1, 2 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ call test (cshift (a, shift1, 2))
+ call test (cshift (a, shift2, 2))
+ call test (cshift (a, shift3, 2))
+ call test (cshift (a, shift4, 2))
+ contains
+ subroutine test (b)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = mod (shift1 (i1, i3) + i2 - 1, n2) + 1
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_eoshift_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_eoshift_1.f90 2005-09-10 15:35:51.000000000 +0100
***************
*** 0 ****
--- 1,51 ----
+ ! Test eoshift0 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 6, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen) :: filler
+ integer (kind = 1) :: shift1 = 4
+ integer (kind = 2) :: shift2 = 2
+ integer (kind = 4) :: shift3 = 3
+ integer (kind = 8) :: shift4 = 1
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'abcdef'(i1:i1) // 'ghijk'(i2:i2) // 'lmno'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, 'foo', 1), int (shift1), 0, 0, 'foo')
+ call test (eoshift (a, shift2, 'foo', 2), 0, int (shift2), 0, 'foo')
+ call test (eoshift (a, shift3, 'foo', 2), 0, int (shift3), 0, 'foo')
+ call test (eoshift (a, shift4, 'foo', 3), 0, 0, int (shift4), 'foo')
+
+ filler = ''
+ call test (eoshift (a, shift1, dim = 1), int (shift1), 0, 0, filler)
+ call test (eoshift (a, shift2, dim = 2), 0, int (shift2), 0, filler)
+ call test (eoshift (a, shift3, dim = 2), 0, int (shift3), 0, filler)
+ call test (eoshift (a, shift4, dim = 3), 0, 0, int (shift4), filler)
+ contains
+ subroutine test (b, d1, d2, d3, filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ character (len = slen) :: filler
+ integer :: d1, d2, d3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (i1 + d1 .gt. n1 .or. i2 + d2 .gt. n2 .or. i3 + d3 .gt. n3) then
+ print *, 'a' // filler // 'b'
+ if (b (i1, i2, i3) .ne. filler) call abort
+ else
+ if (b (i1, i2, i3) .ne. a (i1 + d1, i2 + d2, i3 + d3)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_eoshift_2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_eoshift_2.f90 2005-09-10 15:35:39.000000000 +0100
***************
*** 0 ****
--- 1,57 ----
+ ! Test eoshift1 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen) :: filler
+ integer (kind = 1), dimension (n1, n3) :: shift1
+ integer (kind = 2), dimension (n1, n3) :: shift2
+ integer (kind = 4), dimension (n1, n3) :: shift3
+ integer (kind = 8), dimension (n1, n3) :: shift4
+ integer :: i1, i2, i3
+
+ shift1 (1, :) = (/ 1, 3, 2, 2 /)
+ shift1 (2, :) = (/ 2, 1, 1, 3 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, 'foo', 2), 'foo')
+ call test (eoshift (a, shift2, 'foo', 2), 'foo')
+ call test (eoshift (a, shift3, 'foo', 2), 'foo')
+ call test (eoshift (a, shift4, 'foo', 2), 'foo')
+
+ filler = ''
+ call test (eoshift (a, shift1, dim = 2), filler)
+ call test (eoshift (a, shift2, dim = 2), filler)
+ call test (eoshift (a, shift3, dim = 2), filler)
+ call test (eoshift (a, shift4, dim = 2), filler)
+ contains
+ subroutine test (b, filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ character (len = slen) :: filler
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = i2 + shift1 (i1, i3)
+ if (i2p .gt. n2) then
+ if (b (i1, i2, i3) .ne. filler) call abort
+ else
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_eoshift_3.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_eoshift_3.f90 2005-09-10 15:35:23.000000000 +0100
***************
*** 0 ****
--- 1,54 ----
+ ! Test eoshift2 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen), dimension (n1, n3) :: filler
+ integer (kind = 1) :: shift1 = 4
+ integer (kind = 2) :: shift2 = 2
+ integer (kind = 4) :: shift3 = 3
+ integer (kind = 8) :: shift4 = 1
+ integer :: i1, i2, i3
+
+ filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
+ filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, filler, 2), int (shift1), .true.)
+ call test (eoshift (a, shift2, filler, 2), int (shift2), .true.)
+ call test (eoshift (a, shift3, filler, 2), int (shift3), .true.)
+ call test (eoshift (a, shift4, filler, 2), int (shift4), .true.)
+
+ call test (eoshift (a, shift1, dim = 2), int (shift1), .false.)
+ call test (eoshift (a, shift2, dim = 2), int (shift2), .false.)
+ call test (eoshift (a, shift3, dim = 2), int (shift3), .false.)
+ call test (eoshift (a, shift4, dim = 2), int (shift4), .false.)
+ contains
+ subroutine test (b, d2, has_filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ logical :: has_filler
+ integer :: d2
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (i2 + d2 .le. n2) then
+ if (b (i1, i2, i3) .ne. a (i1, i2 + d2, i3)) call abort
+ else if (has_filler) then
+ if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
+ else
+ if (b (i1, i2, i3) .ne. '') call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_eoshift_4.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_eoshift_4.f90 2005-09-10 15:23:59.000000000 +0100
***************
*** 0 ****
--- 1,61 ----
+ ! Test eoshift3 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen), dimension (n1, n3) :: filler
+ integer (kind = 1), dimension (n1, n3) :: shift1
+ integer (kind = 2), dimension (n1, n3) :: shift2
+ integer (kind = 4), dimension (n1, n3) :: shift3
+ integer (kind = 8), dimension (n1, n3) :: shift4
+ integer :: i1, i2, i3
+
+ filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
+ filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
+
+ shift1 (1, :) = (/ 1, 3, 2, 2 /)
+ shift1 (2, :) = (/ 2, 1, 1, 3 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, filler, 2), .true.)
+ call test (eoshift (a, shift2, filler, 2), .true.)
+ call test (eoshift (a, shift3, filler, 2), .true.)
+ call test (eoshift (a, shift4, filler, 2), .true.)
+
+ call test (eoshift (a, shift1, dim = 2), .false.)
+ call test (eoshift (a, shift2, dim = 2), .false.)
+ call test (eoshift (a, shift3, dim = 2), .false.)
+ call test (eoshift (a, shift4, dim = 2), .false.)
+ contains
+ subroutine test (b, has_filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ logical :: has_filler
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = i2 + shift1 (i1, i3)
+ if (i2p .le. n2) then
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ else if (has_filler) then
+ if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
+ else
+ if (b (i1, i2, i3) .ne. '') call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_pack_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_pack_1.f90 2005-09-09 17:53:29.000000000 +0100
***************
*** 0 ****
--- 1,59 ----
+ ! Test (non-scalar) pack for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test1 (pack (a, mask))
+ call test2 (pack (a, mask, vector))
+ contains
+ subroutine test1 (b)
+ character (len = slen), dimension (:) :: b
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end if
+ end do
+ end do
+ if (size (b, 1) .ne. i) call abort
+ end subroutine test1
+
+ subroutine test2 (b)
+ character (len = slen), dimension (:) :: b
+
+ if (size (b, 1) .ne. nv) call abort
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end if
+ end do
+ end do
+ do i = i + 1, nv
+ if (b (i) .ne. vector (i)) call abort
+ end do
+ end subroutine test2
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_pack_2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_pack_2.f90 2005-09-09 17:53:00.000000000 +0100
***************
*** 0 ****
--- 1,53 ----
+ ! Test scalar pack for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ character (len = slen), dimension (nv) :: vector
+ logical :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ mask = .true.
+ call test1 (pack (a, mask))
+ call test2 (pack (a, mask, vector))
+ contains
+ subroutine test1 (b)
+ character (len = slen), dimension (:) :: b
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ if (size (b, 1) .ne. i) call abort
+ end subroutine test1
+
+ subroutine test2 (b)
+ character (len = slen), dimension (:) :: b
+
+ if (size (b, 1) .ne. nv) call abort
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ do i = i + 1, nv
+ if (b (i) .ne. vector (i)) call abort
+ end do
+ end subroutine test2
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_reshape_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_reshape_1.f90 2005-09-09 17:45:56.000000000 +0100
***************
*** 0 ****
--- 1,43 ----
+ ! Test reshape for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n = 20, slen = 9
+ character (len = slen), dimension (n) :: a, pad
+ integer, dimension (3) :: shape, order
+ integer :: i
+
+ do i = 1, n
+ a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6)
+ pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6)
+ end do
+
+ shape = (/ 4, 6, 5 /)
+ order = (/ 3, 1, 2 /)
+ call test (reshape (a, shape, pad, order))
+ contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :, :) :: b
+ integer :: i1, i2, i3, ai, padi
+
+ do i = 1, 3
+ if (size (b, i) .ne. shape (i)) call abort
+ end do
+ ai = 0
+ padi = 0
+ do i2 = 1, shape (2)
+ do i1 = 1, shape (1)
+ do i3 = 1, shape (3)
+ if (ai .lt. n) then
+ ai = ai + 1
+ if (b (i1, i2, i3) .ne. a (ai)) call abort
+ else
+ padi = padi + 1
+ if (padi .gt. n) padi = 1
+ if (b (i1, i2, i3) .ne. pad (padi)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_spread_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_spread_1.f90 2005-09-09 17:49:55.000000000 +0100
***************
*** 0 ****
--- 1,32 ----
+ ! Test spread for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 10, n3 = 4, slen = 9
+ character (len = slen), dimension (n1, n3) :: a
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i1 = 1, n1
+ a (i1, i3) = 'ab'(i1:i1) // 'cde'(i3:i3) // 'cantrip'
+ end do
+ end do
+
+ call test (spread (a, 2, n2))
+ contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :, :) :: b
+
+ if (size (b, 1) .ne. n1) call abort
+ if (size (b, 2) .ne. n2) call abort
+ if (size (b, 3) .ne. n3) call abort
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i1, i2, i3) .ne. a (i1, i3)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_transpose_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_transpose_1.f90 2005-09-09 17:51:31.000000000 +0100
***************
*** 0 ****
--- 1,29 ----
+ ! Test transpose for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ integer :: i1, i2
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'cantrip'
+ end do
+ end do
+
+ call test (transpose (a))
+ contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :) :: b
+
+ if (size (b, 1) .ne. n2) call abort
+ if (size (b, 2) .ne. n1) call abort
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i2, i1) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_unpack_1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_unpack_1.f90 2005-09-09 17:54:16.000000000 +0100
***************
*** 0 ****
--- 1,44 ----
+ ! Test unpack0 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: field
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ field (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test (unpack (vector, mask, field))
+ contains
+ subroutine test (a)
+ character (len = slen), dimension (:, :) :: a
+
+ if (size (a, 1) .ne. n1) call abort
+ if (size (a, 2) .ne. n2) call abort
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (a (i1, i2) .ne. vector (i)) call abort
+ else
+ if (a (i1, i2) .ne. field (i1, i2)) call abort
+ end if
+ end do
+ end do
+ end subroutine test
+ end program main
diff -c /dev/null gcc/testsuite/gfortran.dg/char_unpack_2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.dg/char_unpack_2.f90 2005-09-09 17:58:51.000000000 +0100
***************
*** 0 ****
--- 1,40 ----
+ ! Test unpack1 for character arrays.
+ ! { dg-do run }
+ program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen) :: field
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ field = 'broadside'
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test (unpack (vector, mask, field))
+ contains
+ subroutine test (a)
+ character (len = slen), dimension (:, :) :: a
+
+ if (size (a, 1) .ne. n1) call abort
+ if (size (a, 2) .ne. n2) call abort
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (a (i1, i2) .ne. vector (i)) call abort
+ else
+ if (a (i1, i2) .ne. field) call abort
+ end if
+ end do
+ end do
+ end subroutine test
+ end program main