Skip to content

R
riscv-gcc-1
Commit 90469382 by Thomas Koenig
Options

re PR libfortran/34671 (any(kind=1) and all(kind=1)) 

2008-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34671
	* gfortran.am: Added _gfortran_all_l1, _gfortran_all_l2,
	_gfortran_any_l1, _gfortran_any_l2, -28,15 _gfortran_count_1_l,
	_gfortran_count_16_l, _gfortran_count_2_l, _gfortran_count_4_l and
	_gfortran_count_8_l Removed _gfortran_count_16_l16,
	_gfortran_count_16_l4, _gfortran_count_16_l8,
	_gfortran_count_4_l16, _gfortran_count_4_l4, _gfortran_count_4_l8,
	_gfortran_count_8_l16, _gfortran_count_8_l4 and
	_gfortran_count_8_l8.
	* Makefile.am: Added generated/any_l1.c and generated/any_l2.c to
	i_any_c.  Added generated/all_l1. and generated/all_l2.c to
	i_all_c.  Removed generated/count_4_l4.c, generated/count_8_l4.c,
	generated/count_16_l4.c, generated/count_4_l8.c,
	generated/count_8_l8.c, generated/count_16_l8.c,
	generated/count_4_l16.c, generated/count_8_l16.c, and
	generated/count_16_l16.c from i_count_c.  Added count_1_l.c,
	count_2_l.c, count_4_l.c, count_8_l.c and count_16_l.c to
	i_count_c.  I_M4_DEPS2 depends on ifunction_logical.m4, for
	any of the files generated from all.m4, any.m4 and count.m4.
	* Makefile.in:  Regenerated.
	* m4/ifunction_logical.m4:  New file.  Use
	GFC_LOGICAL_1 pointer for access to source arrays.
	* m4/any.m4:  Include ifunction_logical.m4 instead of
	ifunction.m4.  Don't check atype_name.
	* m4/all.m4:  Likewise.
	* m4/count.m4:  Likewise.
	* generated/any_l1.c:  New file.
	* generated/any_l2.c:  New file.
	* generated/all_l1.c:  New file.
	* generated/count_1_l.c:  New file.
	* generated/count_2_l.c:  New file.
	* generated/count_4_l.c:  New file.
	* generated/count_8_l.c:  New file.
	* generated/count_16_l.c:  New file.
	* generated/any_l4.c:  Regenerated.
	* generated/any_l8.c:  Regenerated.
	* generated/any_l16.c:  Regenerated.
	* generated/all_l4.c: Regenerated.
	* generated/all_l8.c: Regenerated.
	* generated/all_l16.c: Regenerated.
	* generated/count_4_l4.c:  Removed.
	* generated/count_4_l8.c:  Removed.
	* generated/count_4_l16.c:  Removed.
	* generated/count_8_l4.c:  Removed.
	* generated/count_8_l8.c:  Removed.
	* generated/count_8_l16.c:  Removed.
	* generated/count_16_l4.c:  Removed.
	* generated/count_16_l8.c:  Removed.
	* generated/count_16_l16.c:  Removed.

2008-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/34671
	* iresolve.c (gfc_resolve_all):  Call resolve_mask_arg.
	(gfc_resolve_any):  Likewise.
	(gfc_resolve_count):  Likewise.  Don't append kind of
	argument to function name.

2008-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
	
	PR libfortran/34671
	* gfortran.dg/anyallcount_1.f90:  New test.

From-SVN: r131553
parent ac90ae18
Showing with 872 additions and 284 deletions
gcc/fortran/ChangeLog
2008-01-15 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34671
* iresolve.c (gfc_resolve_all): Call resolve_mask_arg.
(gfc_resolve_any): Likewise.
(gfc_resolve_count): Likewise. Don't append kind of
argument to function name.
2008-01-13 Tobias Burnus <burnus@net-b.de>
PR fortran/34665
......
gcc/fortran/iresolve.c
......@@ -256,6 +256,8 @@ gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
resolve_mask_arg (mask);
f->value.function.name
= gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
......@@ -304,6 +306,8 @@ gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
resolve_mask_arg (mask);
f->value.function.name
= gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
......@@ -549,9 +553,11 @@ gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
resolve_mask_arg (mask);
f->value.function.name
= gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
gfc_type_letter (mask->ts.type), mask->ts.kind);
= gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
gfc_type_letter (mask->ts.type));
}
......
gcc/testsuite/ChangeLog
2008-01-15 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34671
* gfortran.dg/anyallcount_1.f90: New test.
2008-01-15 Douglas Gregor <doug.gregor@gmail.com>
PR c++/34399
gcc/testsuite/gfortran.dg/anyallcount_1.f90 0 → 100644
! { dg-do run }
program main
character(len=*), parameter :: f='(3L1)'
character(len=*), parameter :: g='(3I1)'
real, dimension(3,3) :: a
logical(kind=1), dimension(3,3) :: m1
logical(kind=2), dimension(3,3) :: m2
logical(kind=4), dimension(3,3) :: m4
logical(kind=8), dimension(3,3) :: m8
character(len=3) :: res
data a /-1.0, -2.0, -3.0, 2.0, 1.0, -2.1, 1.0, 2.0, 3.0 /
m1 = a > 0
m2 = a > 0
m4 = a > 0
m8 = a > 0
write (unit=res,fmt=f) any(m1,dim=1)
if (res /= 'FTT') call abort
write (unit=res,fmt=f) any(m2,dim=1)
if (res /= 'FTT') call abort
write (unit=res,fmt=f) any(m4,dim=1)
if (res /= 'FTT') call abort
write (unit=res,fmt=f) any(m8,dim=1)
if (res /= 'FTT') call abort
write (unit=res,fmt=f) any(m1,dim=2)
if (res /= 'TTT') call abort
write (unit=res,fmt=f) any(m2,dim=2)
if (res /= 'TTT') call abort
write (unit=res,fmt=f) any(m4,dim=2)
if (res /= 'TTT') call abort
write (unit=res,fmt=f) any(m8,dim=2)
if (res /= 'TTT') call abort
write (unit=res,fmt=f) all(m1,dim=1)
if (res /= 'FFT') call abort
write (unit=res,fmt=f) all(m2,dim=1)
if (res /= 'FFT') call abort
write (unit=res,fmt=f) all(m4,dim=1)
if (res /= 'FFT') call abort
write (unit=res,fmt=f) all(m8,dim=1)
if (res /= 'FFT') call abort
write (unit=res,fmt=f) all(m1,dim=2)
if (res /= 'FFF') call abort
write (unit=res,fmt=f) all(m2,dim=2)
if (res /= 'FFF') call abort
write (unit=res,fmt=f) all(m4,dim=2)
if (res /= 'FFF') call abort
write (unit=res,fmt=f) all(m8,dim=2)
if (res /= 'FFF') call abort
write (unit=res,fmt=g) count(m1,dim=1)
if (res /= '023') call abort
write (unit=res,fmt=g) count(m2,dim=1)
if (res /= '023') call abort
write (unit=res,fmt=g) count(m4,dim=1)
if (res /= '023') call abort
write (unit=res,fmt=g) count(m8,dim=1)
if (res /= '023') call abort
write (unit=res,fmt=g) count(m1,dim=2)
if (res /= '221') call abort
write (unit=res,fmt=g) count(m2,dim=2)
if (res /= '221') call abort
write (unit=res,fmt=g) count(m4,dim=2)
if (res /= '221') call abort
write (unit=res,fmt=g) count(m8,dim=2)
if (res /= '221') call abort
end program main
libgfortran/ChangeLog
2008-01-15 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34671
* gfortran.am: Added _gfortran_all_l1, _gfortran_all_l2,
_gfortran_any_l1, _gfortran_any_l2, -28,15 _gfortran_count_1_l,
_gfortran_count_16_l, _gfortran_count_2_l, _gfortran_count_4_l and
_gfortran_count_8_l Removed _gfortran_count_16_l16,
_gfortran_count_16_l4, _gfortran_count_16_l8,
_gfortran_count_4_l16, _gfortran_count_4_l4, _gfortran_count_4_l8,
_gfortran_count_8_l16, _gfortran_count_8_l4 and
_gfortran_count_8_l8.
* Makefile.am: Added generated/any_l1.c and generated/any_l2.c to
i_any_c. Added generated/all_l1. and generated/all_l2.c to
i_all_c. Removed generated/count_4_l4.c, generated/count_8_l4.c,
generated/count_16_l4.c, generated/count_4_l8.c,
generated/count_8_l8.c, generated/count_16_l8.c,
generated/count_4_l16.c, generated/count_8_l16.c, and
generated/count_16_l16.c from i_count_c. Added count_1_l.c,
count_2_l.c, count_4_l.c, count_8_l.c and count_16_l.c to
i_count_c. I_M4_DEPS2 depends on ifunction_logical.m4, for
any of the files generated from all.m4, any.m4 and count.m4.
* Makefile.in: Regenerated.
* m4/ifunction_logical.m4: New file. Use
GFC_LOGICAL_1 pointer for access to source arrays.
* m4/any.m4: Include ifunction_logical.m4 instead of
ifunction.m4. Don't check atype_name.
* m4/all.m4: Likewise.
* m4/count.m4: Likewise.
* generated/any_l1.c: New file.
* generated/any_l2.c: New file.
* generated/all_l1.c: New file.
* generated/count_1_l.c: New file.
* generated/count_2_l.c: New file.
* generated/count_4_l.c: New file.
* generated/count_8_l.c: New file.
* generated/count_16_l.c: New file.
* generated/any_l4.c: Regenerated.
* generated/any_l8.c: Regenerated.
* generated/any_l16.c: Regenerated.
* generated/all_l4.c: Regenerated.
* generated/all_l8.c: Regenerated.
* generated/all_l16.c: Regenerated.
* generated/count_4_l4.c: Removed.
* generated/count_4_l8.c: Removed.
* generated/count_4_l16.c: Removed.
* generated/count_8_l4.c: Removed.
* generated/count_8_l8.c: Removed.
* generated/count_8_l16.c: Removed.
* generated/count_16_l4.c: Removed.
* generated/count_16_l8.c: Removed.
* generated/count_16_l16.c: Removed.
2008-01-13 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34746
......
libgfortran/Makefile.am
......@@ -121,25 +121,25 @@ runtime/string.c \
runtime/select.c
i_all_c= \
$(srcdir)/generated/all_l1.c \
$(srcdir)/generated/all_l2.c \
$(srcdir)/generated/all_l4.c \
$(srcdir)/generated/all_l8.c \
$(srcdir)/generated/all_l16.c
i_any_c= \
$(srcdir)/generated/any_l1.c \
$(srcdir)/generated/any_l2.c \
$(srcdir)/generated/any_l4.c \
$(srcdir)/generated/any_l8.c \
$(srcdir)/generated/any_l16.c
i_count_c= \
$(srcdir)/generated/count_4_l4.c \
$(srcdir)/generated/count_8_l4.c \
$(srcdir)/generated/count_16_l4.c \
$(srcdir)/generated/count_4_l8.c \
$(srcdir)/generated/count_8_l8.c \
$(srcdir)/generated/count_16_l8.c \
$(srcdir)/generated/count_4_l16.c \
$(srcdir)/generated/count_8_l16.c \
$(srcdir)/generated/count_16_l16.c
$(srcdir)/generated/count_1_l.c \
$(srcdir)/generated/count_2_l.c \
$(srcdir)/generated/count_4_l.c \
$(srcdir)/generated/count_8_l.c \
$(srcdir)/generated/count_16_l.c
i_maxloc0_c= \
$(srcdir)/generated/maxloc0_4_i1.c \
......@@ -463,7 +463,7 @@ $(srcdir)/generated/pow_c16_i16.c
m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \
m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \
m4/matmul.m4 m4/matmull.m4 \
m4/matmul.m4 m4/matmull.m4 m4/ifunction_logical.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/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \
......@@ -684,6 +684,7 @@ endif
I_M4_DEPS=m4/iparm.m4
I_M4_DEPS0=$(I_M4_DEPS) m4/iforeach.m4
I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4
I_M4_DEPS2=$(I_M4_DEPS) m4/ifunction_logical.m4
kinds.h: $(srcdir)/mk-kinds-h.sh
$(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@
......@@ -707,13 +708,13 @@ fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER)
## so we only include them in maintainer mode
if MAINTAINER_MODE
$(i_all_c): m4/all.m4 $(I_M4_DEPS1)
$(i_all_c): m4/all.m4 $(I_M4_DEPS2)
$(M4) -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@
$(i_any_c): m4/any.m4 $(I_M4_DEPS1)
$(i_any_c): m4/any.m4 $(I_M4_DEPS2)
$(M4) -Dfile=$@ -I$(srcdir)/m4 any.m4 > $@
$(i_count_c): m4/count.m4 $(I_M4_DEPS1)
$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
$(i_maxloc0_c): m4/maxloc0.m4 $(I_M4_DEPS0)
......
libgfortran/generated/count_4_l8.c → libgfortran/generated/all_l1.c
/* Implementation of the COUNT intrinsic
/* Implementation of the ALL intrinsic
Copyright 2002, 2007 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_4)
#if defined (HAVE_GFC_LOGICAL_1)
extern void count_4_l8 (gfc_array_i4 * const restrict,
gfc_array_l8 * const restrict, const index_type * const restrict);
export_proto(count_4_l8);
extern void all_l1 (gfc_array_l1 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(all_l1);
void
count_4_l8 (gfc_array_i4 * const restrict retarray,
gfc_array_l8 * const restrict array,
all_l1 (gfc_array_l1 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_8 * restrict base;
GFC_INTEGER_4 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_1 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_4_l8 (gfc_array_i4 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ALL intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_4_l8 (gfc_array_i4 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ALL intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,25 +148,42 @@ count_4_l8 (gfc_array_i4 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ALL intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_8 * restrict src;
GFC_INTEGER_4 result;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_1 result;
src = base;
{
result = 0;
/* Return true only if all the elements are set. */
result = 1;
if (len <= 0)
*dest = 0;
*dest = 1;
else
{
for (n = 0; n < len; n++, src += delta)
{
if (*src)
result++;
if (! *src)
{
result = 0;
break;
}
}
*dest = result;
}
......
libgfortran/generated/all_l16.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16)
#if defined (HAVE_GFC_LOGICAL_16)
extern void all_l16 (gfc_array_l16 * const restrict,
gfc_array_l16 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(all_l16);
void
all_l16 (gfc_array_l16 * const restrict retarray,
gfc_array_l16 * const restrict array,
gfc_array_l1 * 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_LOGICAL_16 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_16 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ all_l16 (gfc_array_l16 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ all_l16 (gfc_array_l16 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ALL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ALL intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ all_l16 (gfc_array_l16 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ALL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ALL intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ all_l16 (gfc_array_l16 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ALL intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_16 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_16 result;
src = base;
{
......
libgfortran/generated/count_8_l8.c → libgfortran/generated/all_l2.c
/* Implementation of the COUNT intrinsic
/* Implementation of the ALL intrinsic
Copyright 2002, 2007 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_8)
#if defined (HAVE_GFC_LOGICAL_2)
extern void count_8_l8 (gfc_array_i8 * const restrict,
gfc_array_l8 * const restrict, const index_type * const restrict);
export_proto(count_8_l8);
extern void all_l2 (gfc_array_l2 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(all_l2);
void
count_8_l8 (gfc_array_i8 * const restrict retarray,
gfc_array_l8 * const restrict array,
all_l2 (gfc_array_l2 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_8 * restrict base;
GFC_INTEGER_8 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_2 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_8_l8 (gfc_array_i8 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_8_l8 (gfc_array_i8 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_8_l8 (gfc_array_i8 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ALL intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_8_l8 (gfc_array_i8 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ALL intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,25 +148,42 @@ count_8_l8 (gfc_array_i8 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ALL intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_8 * restrict src;
GFC_INTEGER_8 result;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_2 result;
src = base;
{
result = 0;
/* Return true only if all the elements are set. */
result = 1;
if (len <= 0)
*dest = 0;
*dest = 1;
else
{
for (n = 0; n < len; n++, src += delta)
{
if (*src)
result++;
if (! *src)
{
result = 0;
break;
}
}
*dest = result;
}
......
libgfortran/generated/all_l4.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4)
#if defined (HAVE_GFC_LOGICAL_4)
extern void all_l4 (gfc_array_l4 * const restrict,
gfc_array_l4 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(all_l4);
void
all_l4 (gfc_array_l4 * const restrict retarray,
gfc_array_l4 * const restrict array,
gfc_array_l1 * 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_LOGICAL_4 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_4 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ all_l4 (gfc_array_l4 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ all_l4 (gfc_array_l4 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ALL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ALL intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ all_l4 (gfc_array_l4 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ALL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ALL intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ all_l4 (gfc_array_l4 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ALL intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_4 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_4 result;
src = base;
{
......
libgfortran/generated/all_l8.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8)
#if defined (HAVE_GFC_LOGICAL_8)
extern void all_l8 (gfc_array_l8 * const restrict,
gfc_array_l8 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(all_l8);
void
all_l8 (gfc_array_l8 * const restrict retarray,
gfc_array_l8 * const restrict array,
gfc_array_l1 * 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_LOGICAL_8 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_8 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ all_l8 (gfc_array_l8 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ all_l8 (gfc_array_l8 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ALL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ALL intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ all_l8 (gfc_array_l8 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ALL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ALL intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ all_l8 (gfc_array_l8 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ALL intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_8 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_8 result;
src = base;
{
......
libgfortran/generated/count_16_l4.c → libgfortran/generated/any_l1.c
/* Implementation of the COUNT intrinsic
/* Implementation of the ANY intrinsic
Copyright 2002, 2007 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_16)
#if defined (HAVE_GFC_LOGICAL_1)
extern void count_16_l4 (gfc_array_i16 * const restrict,
gfc_array_l4 * const restrict, const index_type * const restrict);
export_proto(count_16_l4);
extern void any_l1 (gfc_array_l1 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(any_l1);
void
count_16_l4 (gfc_array_i16 * const restrict retarray,
gfc_array_l4 * const restrict array,
any_l1 (gfc_array_l1 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_4 * restrict base;
GFC_INTEGER_16 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_1 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ANY intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ANY intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,12 +148,25 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ANY intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_4 * restrict src;
GFC_INTEGER_16 result;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_1 result;
src = base;
{
......@@ -163,8 +178,12 @@ count_16_l4 (gfc_array_i16 * const restrict retarray,
for (n = 0; n < len; n++, src += delta)
{
/* Return true if any of the elements are set. */
if (*src)
result++;
{
result = 1;
break;
}
}
*dest = result;
}
......
libgfortran/generated/any_l16.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16)
#if defined (HAVE_GFC_LOGICAL_16)
extern void any_l16 (gfc_array_l16 * const restrict,
gfc_array_l16 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(any_l16);
void
any_l16 (gfc_array_l16 * const restrict retarray,
gfc_array_l16 * const restrict array,
gfc_array_l1 * 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_LOGICAL_16 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_16 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ any_l16 (gfc_array_l16 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ any_l16 (gfc_array_l16 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ANY intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ANY intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ any_l16 (gfc_array_l16 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ANY intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ANY intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ any_l16 (gfc_array_l16 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ANY intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_16 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_16 result;
src = base;
{
......
libgfortran/generated/count_4_l4.c → libgfortran/generated/any_l2.c
/* Implementation of the COUNT intrinsic
/* Implementation of the ANY intrinsic
Copyright 2002, 2007 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_4)
#if defined (HAVE_GFC_LOGICAL_2)
extern void count_4_l4 (gfc_array_i4 * const restrict,
gfc_array_l4 * const restrict, const index_type * const restrict);
export_proto(count_4_l4);
extern void any_l2 (gfc_array_l2 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(any_l2);
void
count_4_l4 (gfc_array_i4 * const restrict retarray,
gfc_array_l4 * const restrict array,
any_l2 (gfc_array_l2 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_4 * restrict base;
GFC_INTEGER_4 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_2 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ANY intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ANY intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,12 +148,25 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ANY intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_4 * restrict src;
GFC_INTEGER_4 result;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_2 result;
src = base;
{
......@@ -163,8 +178,12 @@ count_4_l4 (gfc_array_i4 * const restrict retarray,
for (n = 0; n < len; n++, src += delta)
{
/* Return true if any of the elements are set. */
if (*src)
result++;
{
result = 1;
break;
}
}
*dest = result;
}
......
libgfortran/generated/any_l4.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4)
#if defined (HAVE_GFC_LOGICAL_4)
extern void any_l4 (gfc_array_l4 * const restrict,
gfc_array_l4 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(any_l4);
void
any_l4 (gfc_array_l4 * const restrict retarray,
gfc_array_l4 * const restrict array,
gfc_array_l1 * 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_LOGICAL_4 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_4 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ any_l4 (gfc_array_l4 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ any_l4 (gfc_array_l4 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ANY intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ANY intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ any_l4 (gfc_array_l4 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ANY intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ANY intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ any_l4 (gfc_array_l4 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ANY intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_4 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_4 result;
src = base;
{
......
libgfortran/generated/any_l8.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8)
#if defined (HAVE_GFC_LOGICAL_8)
extern void any_l8 (gfc_array_l8 * const restrict,
gfc_array_l8 * const restrict, const index_type * const restrict);
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(any_l8);
void
any_l8 (gfc_array_l8 * const restrict retarray,
gfc_array_l8 * const restrict array,
gfc_array_l1 * 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_LOGICAL_8 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_LOGICAL_8 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ any_l8 (gfc_array_l8 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ any_l8 (gfc_array_l8 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" ANY intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" ANY intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ any_l8 (gfc_array_l8 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" ANY intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" ANY intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ any_l8 (gfc_array_l8 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in ANY intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_8 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_LOGICAL_8 result;
src = base;
{
......
libgfortran/generated/count_16_l8.c → libgfortran/generated/count_16_l.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_16)
#if defined (HAVE_GFC_INTEGER_16)
extern void count_16_l8 (gfc_array_i16 * const restrict,
gfc_array_l8 * const restrict, const index_type * const restrict);
export_proto(count_16_l8);
extern void count_16_l (gfc_array_i16 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(count_16_l);
void
count_16_l8 (gfc_array_i16 * const restrict retarray,
gfc_array_l8 * const restrict array,
count_16_l (gfc_array_i16 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_8 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_INTEGER_16 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_16_l8 (gfc_array_i16 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ count_16_l8 (gfc_array_i16 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" COUNT intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_16_l8 (gfc_array_i16 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" COUNT intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ count_16_l8 (gfc_array_i16 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in COUNT intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_8 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_INTEGER_16 result;
src = base;
{
......
libgfortran/generated/count_8_l4.c → libgfortran/generated/count_1_l.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_8)
#if defined (HAVE_GFC_INTEGER_1)
extern void count_8_l4 (gfc_array_i8 * const restrict,
gfc_array_l4 * const restrict, const index_type * const restrict);
export_proto(count_8_l4);
extern void count_1_l (gfc_array_i1 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(count_1_l);
void
count_8_l4 (gfc_array_i8 * const restrict retarray,
gfc_array_l4 * const restrict array,
count_1_l (gfc_array_i1 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_4 * restrict base;
GFC_INTEGER_8 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_INTEGER_1 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_8_l4 (gfc_array_i8 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" COUNT intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_8_l4 (gfc_array_i8 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" COUNT intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,12 +148,25 @@ count_8_l4 (gfc_array_i8 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in COUNT intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_4 * restrict src;
GFC_INTEGER_8 result;
const GFC_LOGICAL_1 * restrict src;
GFC_INTEGER_1 result;
src = base;
{
......
libgfortran/generated/count_16_l16.c → libgfortran/generated/count_2_l.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_16)
#if defined (HAVE_GFC_INTEGER_2)
extern void count_16_l16 (gfc_array_i16 * const restrict,
gfc_array_l16 * const restrict, const index_type * const restrict);
export_proto(count_16_l16);
extern void count_2_l (gfc_array_i2 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(count_2_l);
void
count_16_l16 (gfc_array_i16 * const restrict retarray,
gfc_array_l16 * const restrict array,
count_2_l (gfc_array_i2 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_16 * restrict base;
GFC_INTEGER_16 * restrict dest;
const GFC_LOGICAL_1 * restrict base;
GFC_INTEGER_2 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_16_l16 (gfc_array_i16 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -99,7 +102,7 @@ count_16_l16 (gfc_array_i16 * const restrict retarray,
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
......@@ -116,9 +119,8 @@ count_16_l16 (gfc_array_i16 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" COUNT intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_16_l16 (gfc_array_i16 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" COUNT intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,12 +148,25 @@ count_16_l16 (gfc_array_i16 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in COUNT intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_16 * restrict src;
GFC_INTEGER_16 result;
const GFC_LOGICAL_1 * restrict src;
GFC_INTEGER_2 result;
src = base;
{
......
libgfortran/generated/count_4_l16.c → libgfortran/generated/count_4_l.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_4)
#if defined (HAVE_GFC_INTEGER_4)
extern void count_4_l16 (gfc_array_i4 * const restrict,
gfc_array_l16 * const restrict, const index_type * const restrict);
export_proto(count_4_l16);
extern void count_4_l (gfc_array_i4 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(count_4_l);
void
count_4_l16 (gfc_array_i4 * const restrict retarray,
gfc_array_l16 * const restrict array,
count_4_l (gfc_array_i4 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_16 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_INTEGER_4 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_4_l16 (gfc_array_i4 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ count_4_l16 (gfc_array_i4 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" COUNT intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_4_l16 (gfc_array_i4 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" COUNT intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ count_4_l16 (gfc_array_i4 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in COUNT intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_16 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_INTEGER_4 result;
src = base;
{
......
libgfortran/generated/count_8_l16.c → libgfortran/generated/count_8_l.c
......@@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>
#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_8)
#if defined (HAVE_GFC_INTEGER_8)
extern void count_8_l16 (gfc_array_i8 * const restrict,
gfc_array_l16 * const restrict, const index_type * const restrict);
export_proto(count_8_l16);
extern void count_8_l (gfc_array_i8 * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(count_8_l);
void
count_8_l16 (gfc_array_i8 * const restrict retarray,
gfc_array_l16 * const restrict array,
count_8_l (gfc_array_i8 * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_16 * restrict base;
const GFC_LOGICAL_1 * restrict base;
GFC_INTEGER_8 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
......@@ -74,7 +77,7 @@ count_8_l16 (gfc_array_i8 * const restrict retarray,
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
......@@ -116,9 +119,8 @@ count_8_l16 (gfc_array_i8 * const restrict retarray,
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" COUNT intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
" COUNT intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
......@@ -130,8 +132,8 @@ count_8_l16 (gfc_array_i8 * const restrict retarray,
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" COUNT intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
" COUNT intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
......@@ -146,11 +148,24 @@ count_8_l16 (gfc_array_i8 * const restrict retarray,
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in COUNT intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_16 * restrict src;
const GFC_LOGICAL_1 * restrict src;
GFC_INTEGER_8 result;
src = base;
{
......
libgfortran/gfortran.map
......@@ -8,10 +8,14 @@ GFORTRAN_1.0 {
_gfortran_alarm_sub_i8;
_gfortran_alarm_sub_int_i4;
_gfortran_alarm_sub_int_i8;
_gfortran_all_l1;
_gfortran_all_l16;
_gfortran_all_l2;
_gfortran_all_l4;
_gfortran_all_l8;
_gfortran_any_l1;
_gfortran_any_l16;
_gfortran_any_l2;
_gfortran_any_l4;
_gfortran_any_l8;
_gfortran_arandom_r10;
......@@ -28,15 +32,11 @@ GFORTRAN_1.0 {
_gfortran_chmod_i8_sub;
_gfortran_compare_string;
_gfortran_concat_string;
_gfortran_count_16_l16;
_gfortran_count_16_l4;
_gfortran_count_16_l8;
_gfortran_count_4_l16;
_gfortran_count_4_l4;
_gfortran_count_4_l8;
_gfortran_count_8_l16;
_gfortran_count_8_l4;
_gfortran_count_8_l8;
_gfortran_count_1_l;
_gfortran_count_16_l;
_gfortran_count_2_l;
_gfortran_count_4_l;
_gfortran_count_8_l;
_gfortran_cpu_time_10;
_gfortran_cpu_time_16;
_gfortran_cpu_time_4;
......
libgfortran/m4/all.m4
......@@ -33,9 +33,9 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>'
include(iparm.m4)dnl
include(ifunction.m4)dnl
include(ifunction_logical.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
`#if defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(1,
` /* Return true only if all the elements are set. */
......
libgfortran/m4/any.m4
......@@ -33,9 +33,9 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>'
include(iparm.m4)dnl
include(ifunction.m4)dnl
include(ifunction_logical.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
`#if defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(0,
` result = 0;',
......
libgfortran/m4/count.m4
......@@ -33,9 +33,9 @@ Boston, MA 02110-1301, USA. */
#include <assert.h>'
include(iparm.m4)dnl
include(ifunction.m4)dnl
include(ifunction_logical.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
`#if defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(0,
` result = 0;',
......
libgfortran/m4/ifunction_logical.m4 0 → 100644
dnl Support macro file for intrinsic functions.
dnl Contains the generic sections of the array functions.
dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)
dnl Distributed under the GNU GPL with exception. See COPYING for details.
dnl
dnl Pass the implementation for a single section as the parameter to
dnl {MASK_}ARRAY_FUNCTION.
dnl The variables base, delta, and len describe the input section.
dnl For masked section the mask is described by mbase and mdelta.
dnl These should not be modified. The result should be stored in *dest.
dnl The names count, extent, sstride, dstride, base, dest, rank, dim
dnl retarray, array, pdim and mstride should not be used.
dnl The variable n is declared as index_type and may be used.
dnl Other variable declarations may be placed at the start of the code,
dnl The types of the array parameter and the return value are
dnl atype_name and rtype_name respectively.
dnl Execution should be allowed to continue to the end of the block.
dnl You should not return or break from the inner loop of the implementation.
dnl Care should also be taken to avoid using the names defined in iparm.m4
define(START_ARRAY_FUNCTION,
`
extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
gfc_array_l1 * const restrict, const index_type * const restrict);
export_proto(name`'rtype_qual`_'atype_code);
void
name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
gfc_array_l1 * 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_LOGICAL_1 * restrict base;
rtype_name * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int src_kind;
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
src_kind = GFC_DESCRIPTOR_SIZE (array);
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
delta = array->dim[dim].stride * src_kind;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride * src_kind;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride * src_kind;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->data == NULL)
{
size_t alloc_size;
for (n = 0; n < rank; n++)
{
retarray->dim[n].lbound = 0;
retarray->dim[n].ubound = extent[n]-1;
if (n == 0)
retarray->dim[n].stride = 1;
else
retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -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"
" u_name intrinsic: is %d, should be %d",
GFC_DESCRIPTOR_RANK (retarray), rank);
if (compile_options.bounds_check)
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = retarray->dim[n].ubound + 1
- retarray->dim[n].lbound;
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" u_name intrinsic in dimension %d:"
" is %ld, should be %ld", n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
if (extent[n] <= 0)
len = 0;
}
base = array->data;
if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| src_kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, src_kind);
}
else
internal_error (NULL, "Funny sized logical array in u_name intrinsic");
dest = retarray->data;
while (base)
{
const GFC_LOGICAL_1 * restrict src;
rtype_name result;
src = base;
{
')dnl
define(START_ARRAY_BLOCK,
` if (len <= 0)
*dest = '$1`;
else
{
for (n = 0; n < len; n++, src += delta)
{
')dnl
define(FINISH_ARRAY_FUNCTION,
` }
*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. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}')dnl
define(ARRAY_FUNCTION,
`START_ARRAY_FUNCTION
$2
START_ARRAY_BLOCK($1)
$3
FINISH_ARRAY_FUNCTION')dnl
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment