URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [m4/] [iforeach.m4] - Rev 745
Go to most recent revision | Compare with Previous | Blame | View Log
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. define(START_FOREACH_FUNCTION, ` extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array); export_proto(name`'rtype_qual`_'atype_code); void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride; const atype_name *base; rtype_name * restrict dest; index_type rank; index_type n; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) runtime_error ("Rank of array needs to be > 0"); if (retarray->data == NULL) { GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; retarray->offset = 0; retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); } else { if (unlikely (compile_options.bounds_check)) bounds_iforeach_return ((array_t *) retarray, (array_t *) array, "u_name"); } dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); count[n] = 0; if (extent[n] <= 0) { /* Set the return value. */ for (n = 0; n < rank; n++) dest[n * dstride] = 0; return; } } base = array->data; /* Initialize the return value. */ for (n = 0; n < rank; n++) dest[n * dstride] = 1; { ')dnl define(START_FOREACH_BLOCK, ` while (base) { do { /* Implementation start. */ ')dnl define(FINISH_FOREACH_FUNCTION, ` /* Implementation end. */ /* Advance to the next element. */ base += sstride[0]; } while (++count[0] != extent[0]); n = 0; do { /* 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]; n++; if (n == rank) { /* Break out of the loop. */ base = NULL; break; } else { count[n]++; base += sstride[n]; } } while (count[n] == extent[n]); } } }')dnl define(START_MASKED_FOREACH_FUNCTION, ` extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, atype * const restrict, gfc_array_l1 * const restrict); export_proto(`m'name`'rtype_qual`_'atype_code); void `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array, gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type mstride[GFC_MAX_DIMENSIONS]; index_type dstride; rtype_name *dest; const atype_name *base; GFC_LOGICAL_1 *mbase; int rank; index_type n; int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) runtime_error ("Rank of array needs to be > 0"); if (retarray->data == NULL) { GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; retarray->offset = 0; retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); } else { if (unlikely (compile_options.bounds_check)) { bounds_iforeach_return ((array_t *) retarray, (array_t *) array, "u_name"); bounds_equal_extents ((array_t *) mask, (array_t *) array, "MASK argument", "u_name"); } } mask_kind = GFC_DESCRIPTOR_SIZE (mask); mbase = mask->data; if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 || mask_kind == 16 #endif ) mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); else runtime_error ("Funny sized logical array"); dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); count[n] = 0; if (extent[n] <= 0) { /* Set the return value. */ for (n = 0; n < rank; n++) dest[n * dstride] = 0; return; } } base = array->data; /* Initialize the return value. */ for (n = 0; n < rank; n++) dest[n * dstride] = 0; { ')dnl define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl define(FINISH_MASKED_FOREACH_FUNCTION, ` /* Implementation end. */ /* Advance to the next element. */ base += sstride[0]; mbase += mstride[0]; } while (++count[0] != extent[0]); n = 0; do { /* When we get to the end of a dimension, reset it and increment the next dimension. */ count[n] = 0; /* We could precalculate these products, but this is a less frequently used path so probably not worth it. */ base -= sstride[n] * extent[n]; mbase -= mstride[n] * extent[n]; n++; if (n == rank) { /* Break out of the loop. */ base = NULL; break; } else { count[n]++; base += sstride[n]; mbase += mstride[n]; } } while (count[n] == extent[n]); } } }')dnl define(FOREACH_FUNCTION, `START_FOREACH_FUNCTION $1 START_FOREACH_BLOCK $2 FINISH_FOREACH_FUNCTION')dnl define(MASKED_FOREACH_FUNCTION, `START_MASKED_FOREACH_FUNCTION $1 START_MASKED_FOREACH_BLOCK $2 FINISH_MASKED_FOREACH_FUNCTION')dnl define(SCALAR_FOREACH_FUNCTION, ` extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, atype * const restrict, GFC_LOGICAL_4 *); export_proto(`s'name`'rtype_qual`_'atype_code); void `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array, GFC_LOGICAL_4 * mask) { index_type rank; index_type dstride; index_type n; rtype_name *dest; if (*mask) { name`'rtype_qual`_'atype_code (retarray, array); return; } rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) runtime_error ("Rank of array needs to be > 0"); if (retarray->data == NULL) { GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; retarray->offset = 0; retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); } else if (unlikely (compile_options.bounds_check)) { bounds_iforeach_return ((array_t *) retarray, (array_t *) array, "u_name"); } dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); dest = retarray->data; for (n = 0; n<rank; n++) dest[n * dstride] = $1 ; }')dnl
Go to most recent revision | Compare with Previous | Blame | View Log