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 = GFC_DESCRIPTOR_EXTENT(array,dim);
  52   if (len < 0)
  53     len = 0;
  54
  55   delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
  56
  57   for (n = 0; n < dim; n++)
  58     {
  59       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
  60       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  61
  62       if (extent[n] < 0)
  63         extent[n] = 0;
  64     }
  65   for (n = dim; n < rank; n++)
  66     {
  67       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1);
  68       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1);
  69
  70       if (extent[n] < 0)
  71         extent[n] = 0;
  72     }
  73
  74   if (retarray->data == NULL)
  75     {
  76       size_t alloc_size, str;
  77
  78       for (n = 0; n < rank; n++)
  79         {
  80           if (n == 0)
  81             str = 1;
  82           else
  83             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  84
  85           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  86
  87         }
  88
  89       retarray->offset = 0;
  90       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  91
  92       alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
  93                    * extent[rank-1];
  94
  95       if (alloc_size == 0)
  96         {
  97           /* Make sure we have a zero-sized array.  */
  98           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
  99           return;
 100         }
 101       else
 102         retarray->data = internal_malloc_size (alloc_size);
 103     }
 104   else
 105     {
 106       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 107         runtime_error ("rank of return array incorrect in"
 108                        " u_name intrinsic: is %ld, should be %ld",
 109                        (long int) GFC_DESCRIPTOR_RANK (retarray),
 110                        (long int) rank);
 111
 112       if (unlikely (compile_options.bounds_check))
 113         {
 114           for (n=0; n < rank; n++)
 115             {
 116               index_type ret_extent;
 117
 118               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 119               if (extent[n] != ret_extent)
 120                 runtime_error ("Incorrect extent in return value of"
 121                                " u_name intrinsic in dimension %d:"
 122                                " is %ld, should be %ld", (int) n + 1,
 123                                (long int) ret_extent, (long int) extent[n]);
 124             }
 125         }
 126     }
 127
 128   for (n = 0; n < rank; n++)
 129     {
 130       count[n] = 0;
 131       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 132       if (extent[n] <= 0)
 133         return;
 134     }
 135
 136   base = array->data;
 137
 138   if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
 139 #ifdef HAVE_GFC_LOGICAL_16
 140       || src_kind == 16
 141 #endif
 142     )
 143     {
 144       if (base)
 145         base = GFOR_POINTER_TO_L1 (base, src_kind);
 146     }
 147   else
 148     internal_error (NULL, "Funny sized logical array in u_name intrinsic");
 149
 150   dest = retarray->data;
 151
 152   continue_loop = 1;
 153   while (continue_loop)
 154     {
 155       const GFC_LOGICAL_1 * restrict src;
 156       rtype_name result;
 157       src = base;
 158       {
 159 ')dnl
 160 define(START_ARRAY_BLOCK,
 161 `        if (len <= 0)
 162           *dest = '$1`;
 163         else
 164           {
 165             for (n = 0; n < len; n++, src += delta)
 166               {
 167 ')dnl
 168 define(FINISH_ARRAY_FUNCTION,
 169     `          }
 170             *dest = result;
 171           }
 172       }
 173       /* Advance to the next element.  */
 174       count[0]++;
 175       base += sstride[0];
 176       dest += dstride[0];
 177       n = 0;
 178       while (count[n] == extent[n])
 179         {
 180           /* When we get to the end of a dimension, reset it and increment
 181              the next dimension.  */
 182           count[n] = 0;
 183           /* We could precalculate these products, but this is a less
 184              frequently used path so probably not worth it.  */
 185           base -= sstride[n] * extent[n];
 186           dest -= dstride[n] * extent[n];
 187           n++;
 188           if (n == rank)
 189             {
 190               /* Break out of the look.  */
 191               continue_loop = 0;
 192               break;
 193             }
 194           else
 195             {
 196               count[n]++;
 197               base += sstride[n];
 198               dest += dstride[n];
 199             }
 200         }
 201     }
 202 }')dnl
 203 define(ARRAY_FUNCTION,
 204 `START_ARRAY_FUNCTION
 205 $2
 206 START_ARRAY_BLOCK($1)
 207 $3
 208 FINISH_ARRAY_FUNCTION')dnl