libgfortran/m4/ifunction_logical.m4

   1 dnl Support macro file for intrinsic functions.
   2 dnl Contains the generic sections of the array functions.
   3 dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)
   4 dnl Distributed under the GNU GPL with exception.  See COPYING for details.
   5 dnl
   6 dnl Pass the implementation for a single section as the parameter to
   7 dnl {MASK_}ARRAY_FUNCTION.
   8 dnl The variables base, delta, and len describe the input section.
   9 dnl For masked section the mask is described by mbase and mdelta.
  10 dnl These should not be modified. The result should be stored in *dest.
  11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim
  12 dnl retarray, array, pdim and mstride should not be used.
  13 dnl The variable n is declared as index_type and may be used.
  14 dnl Other variable declarations may be placed at the start of the code,
  15 dnl The types of the array parameter and the return value are
  16 dnl atype_name and rtype_name respectively.
  17 dnl Execution should be allowed to continue to the end of the block.
  18 dnl You should not return or break from the inner loop of the implementation.
  19 dnl Care should also be taken to avoid using the names defined in iparm.m4
  20 define(START_ARRAY_FUNCTION,
  21 `
  22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
  23         gfc_array_l1 * const restrict, const index_type * const restrict);
  24 export_proto(name`'rtype_qual`_'atype_code);
  25
  26 void
  27 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
  28         gfc_array_l1 * const restrict array,
  29         const index_type * const restrict pdim)
  30 {
  31   index_type count[GFC_MAX_DIMENSIONS];
  32   index_type extent[GFC_MAX_DIMENSIONS];
  33   index_type sstride[GFC_MAX_DIMENSIONS];
  34   index_type dstride[GFC_MAX_DIMENSIONS];
  35   const GFC_LOGICAL_1 * restrict base;
  36   rtype_name * restrict dest;
  37   index_type rank;
  38   index_type n;
  39   index_type len;
  40   index_type delta;
  41   index_type dim;
  42   int src_kind;
  43   int continue_loop;
  44
  45   /* Make dim zero based to avoid confusion.  */
  46   dim = (*pdim) - 1;
  47   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  48
  49   src_kind = GFC_DESCRIPTOR_SIZE (array);
  50
  51   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  52   if (len < 0)
  53     len = 0;
  54
  55   delta = array->dim[dim].stride * src_kind;
  56
  57   for (n = 0; n < dim; n++)
  58     {
  59       sstride[n] = array->dim[n].stride * src_kind;
  60       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  61
  62       if (extent[n] < 0)
  63         extent[n] = 0;
  64     }
  65   for (n = dim; n < rank; n++)
  66     {
  67       sstride[n] = array->dim[n + 1].stride * src_kind;
  68       extent[n] =
  69         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  70
  71       if (extent[n] < 0)
  72         extent[n] = 0;
  73     }
  74
  75   if (retarray->data == NULL)
  76     {
  77       size_t alloc_size;
  78
  79       for (n = 0; n < rank; n++)
  80         {
  81           retarray->dim[n].lbound = 0;
  82           retarray->dim[n].ubound = extent[n]-1;
  83           if (n == 0)
  84             retarray->dim[n].stride = 1;
  85           else
  86             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  87         }
  88
  89       retarray->offset = 0;
  90       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  91
  92       alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
  93                    * extent[rank-1];
  94
  95       if (alloc_size == 0)
  96         {
  97           /* Make sure we have a zero-sized array.  */
  98           retarray->dim[0].lbound = 0;
  99           retarray->dim[0].ubound = -1;
 100           return;
 101         }
 102       else
 103         retarray->data = internal_malloc_size (alloc_size);
 104     }
 105   else
 106     {
 107       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 108         runtime_error ("rank of return array incorrect in"
 109                        " u_name intrinsic: is %ld, should be %ld",
 110                        (long int) GFC_DESCRIPTOR_RANK (retarray),
 111                        (long int) rank);
 112
 113       if (compile_options.bounds_check)
 114         {
 115           for (n=0; n < rank; n++)
 116             {
 117               index_type ret_extent;
 118
 119               ret_extent = retarray->dim[n].ubound + 1
 120                 - retarray->dim[n].lbound;
 121               if (extent[n] != ret_extent)
 122                 runtime_error ("Incorrect extent in return value of"
 123                                " u_name intrinsic in dimension %d:"
 124                                " is %ld, should be %ld", n + 1,
 125                                (long int) ret_extent, (long int) extent[n]);
 126             }
 127         }
 128     }
 129
 130   for (n = 0; n < rank; n++)
 131     {
 132       count[n] = 0;
 133       dstride[n] = retarray->dim[n].stride;
 134       if (extent[n] <= 0)
 135         len = 0;
 136     }
 137
 138   base = array->data;
 139
 140   if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
 141 #ifdef HAVE_GFC_LOGICAL_16
 142       || src_kind == 16
 143 #endif
 144     )
 145     {
 146       if (base)
 147         base = GFOR_POINTER_TO_L1 (base, src_kind);
 148     }
 149   else
 150     internal_error (NULL, "Funny sized logical array in u_name intrinsic");
 151
 152   dest = retarray->data;
 153
 154   continue_loop = 1;
 155   while (continue_loop)
 156     {
 157       const GFC_LOGICAL_1 * restrict src;
 158       rtype_name result;
 159       src = base;
 160       {
 161 ')dnl
 162 define(START_ARRAY_BLOCK,
 163 `        if (len <= 0)
 164           *dest = '$1`;
 165         else
 166           {
 167             for (n = 0; n < len; n++, src += delta)
 168               {
 169 ')dnl
 170 define(FINISH_ARRAY_FUNCTION,
 171     `          }
 172             *dest = result;
 173           }
 174       }
 175       /* Advance to the next element.  */
 176       count[0]++;
 177       base += sstride[0];
 178       dest += dstride[0];
 179       n = 0;
 180       while (count[n] == extent[n])
 181         {
 182           /* When we get to the end of a dimension, reset it and increment
 183              the next dimension.  */
 184           count[n] = 0;
 185           /* We could precalculate these products, but this is a less
 186              frequently used path so probably not worth it.  */
 187           base -= sstride[n] * extent[n];
 188           dest -= dstride[n] * extent[n];
 189           n++;
 190           if (n == rank)
 191             {
 192               /* Break out of the look.  */
 193               continue_loop = 0;
 194               break;
 195             }
 196           else
 197             {
 198               count[n]++;
 199               base += sstride[n];
 200               dest += dstride[n];
 201             }
 202         }
 203     }
 204 }')dnl
 205 define(ARRAY_FUNCTION,
 206 `START_ARRAY_FUNCTION
 207 $2
 208 START_ARRAY_BLOCK($1)
 209 $3
 210 FINISH_ARRAY_FUNCTION')dnl