libgfortran/m4/eoshift3.m4

   1 `/* Implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <assert.h>
  29 #include <string.h>'
  30
  31 include(iparm.m4)dnl
  32
  33 `#if defined (HAVE_'atype_name`)
  34
  35 static void
  36 eoshift3 (gfc_array_char * const restrict ret,
  37         const gfc_array_char * const restrict array,
  38         const 'atype` * const restrict h,
  39         const gfc_array_char * const restrict bound,
  40         const 'atype_name` * const restrict pwhich,
  41         const char * filler, index_type filler_len)
  42 {
  43   /* r.* indicates the return array.  */
  44   index_type rstride[GFC_MAX_DIMENSIONS];
  45   index_type rstride0;
  46   index_type roffset;
  47   char *rptr;
  48   char * restrict dest;
  49   /* s.* indicates the source array.  */
  50   index_type sstride[GFC_MAX_DIMENSIONS];
  51   index_type sstride0;
  52   index_type soffset;
  53   const char *sptr;
  54   const char *src;
  55   /* h.* indicates the shift array.  */
  56   index_type hstride[GFC_MAX_DIMENSIONS];
  57   index_type hstride0;
  58   const 'atype_name` *hptr;
  59   /* b.* indicates the bound array.  */
  60   index_type bstride[GFC_MAX_DIMENSIONS];
  61   index_type bstride0;
  62   const char *bptr;
  63
  64   index_type count[GFC_MAX_DIMENSIONS];
  65   index_type extent[GFC_MAX_DIMENSIONS];
  66   index_type dim;
  67   index_type len;
  68   index_type n;
  69   index_type size;
  70   index_type arraysize;
  71   int which;
  72   'atype_name` sh;
  73   'atype_name` delta;
  74
  75   /* The compiler cannot figure out that these are set, initialize
  76      them to avoid warnings.  */
  77   len = 0;
  78   soffset = 0;
  79   roffset = 0;
  80
  81   arraysize = size0 ((array_t *) array);
  82   size = GFC_DESCRIPTOR_SIZE(array);
  83
  84   if (pwhich)
  85     which = *pwhich - 1;
  86   else
  87     which = 0;
  88
  89   if (ret->data == NULL)
  90     {
  91       int i;
  92
  93       ret->offset = 0;
  94       ret->dtype = array->dtype;
  95       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  96         {
  97           index_type ub, str;
  98
  99           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
 100
 101           if (i == 0)
 102             str = 1;
 103           else
 104             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
 105               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
 106
 107           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 108
 109         }
 110       /* internal_malloc_size allocates a single byte for zero size.  */
 111       ret->data = internal_malloc_size (size * arraysize);
 112
 113     }
 114   else if (unlikely (compile_options.bounds_check))
 115     {
 116       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 117                                  "return value", "EOSHIFT");
 118     }
 119
 120   if (unlikely (compile_options.bounds_check))
 121     {
 122       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 123                               "SHIFT argument", "EOSHIFT");
 124     }
 125
 126   if (arraysize == 0)
 127     return;
 128
 129   extent[0] = 1;
 130   count[0] = 0;
 131   n = 0;
 132   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 133     {
 134       if (dim == which)
 135         {
 136           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 137           if (roffset == 0)
 138             roffset = size;
 139           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 140           if (soffset == 0)
 141             soffset = size;
 142           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 143         }
 144       else
 145         {
 146           count[n] = 0;
 147           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 148           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 149           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 150
 151           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 152           if (bound)
 153             bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
 154           else
 155             bstride[n] = 0;
 156           n++;
 157         }
 158     }
 159   if (sstride[0] == 0)
 160     sstride[0] = size;
 161   if (rstride[0] == 0)
 162     rstride[0] = size;
 163   if (hstride[0] == 0)
 164     hstride[0] = 1;
 165   if (bound && bstride[0] == 0)
 166     bstride[0] = size;
 167
 168   dim = GFC_DESCRIPTOR_RANK (array);
 169   rstride0 = rstride[0];
 170   sstride0 = sstride[0];
 171   hstride0 = hstride[0];
 172   bstride0 = bstride[0];
 173   rptr = ret->data;
 174   sptr = array->data;
 175   hptr = h->data;
 176   if (bound)
 177     bptr = bound->data;
 178   else
 179     bptr = NULL;
 180
 181   while (rptr)
 182     {
 183       /* Do the shift for this dimension.  */
 184       sh = *hptr;
 185       if (( sh >= 0 ? sh : -sh ) > len)
 186         {
 187           delta = len;
 188           sh = len;
 189         }
 190       else
 191         delta = (sh >= 0) ? sh: -sh;
 192
 193       if (sh > 0)
 194         {
 195           src = &sptr[delta * soffset];
 196           dest = rptr;
 197         }
 198       else
 199         {
 200           src = sptr;
 201           dest = &rptr[delta * roffset];
 202         }
 203       for (n = 0; n < len - delta; n++)
 204         {
 205           memcpy (dest, src, size);
 206           dest += roffset;
 207           src += soffset;
 208         }
 209       if (sh < 0)
 210         dest = rptr;
 211       n = delta;
 212
 213       if (bptr)
 214         while (n--)
 215           {
 216             memcpy (dest, bptr, size);
 217             dest += roffset;
 218           }
 219       else
 220         while (n--)
 221           {
 222             index_type i;
 223
 224             if (filler_len == 1)
 225               memset (dest, filler[0], size);
 226             else
 227               for (i = 0; i < size; i += filler_len)
 228                 memcpy (&dest[i], filler, filler_len);
 229
 230             dest += roffset;
 231           }
 232
 233       /* Advance to the next section.  */
 234       rptr += rstride0;
 235       sptr += sstride0;
 236       hptr += hstride0;
 237       bptr += bstride0;
 238       count[0]++;
 239       n = 0;
 240       while (count[n] == extent[n])
 241         {
 242           /* When we get to the end of a dimension, reset it and increment
 243              the next dimension.  */
 244           count[n] = 0;
 245           /* We could precalculate these products, but this is a less
 246              frequently used path so probably not worth it.  */
 247           rptr -= rstride[n] * extent[n];
 248           sptr -= sstride[n] * extent[n];
 249           hptr -= hstride[n] * extent[n];
 250           bptr -= bstride[n] * extent[n];
 251           n++;
 252           if (n >= dim - 1)
 253             {
 254               /* Break out of the loop.  */
 255               rptr = NULL;
 256               break;
 257             }
 258           else
 259             {
 260               count[n]++;
 261               rptr += rstride[n];
 262               sptr += sstride[n];
 263               hptr += hstride[n];
 264               bptr += bstride[n];
 265             }
 266         }
 267     }
 268 }
 269
 270 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 271         const gfc_array_char * const restrict,
 272         const 'atype` * const restrict,
 273         const gfc_array_char * const restrict,
 274         const 'atype_name` *);
 275 export_proto(eoshift3_'atype_kind`);
 276
 277 void
 278 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 279         const gfc_array_char * const restrict array,
 280         const 'atype` * const restrict h,
 281         const gfc_array_char * const restrict bound,
 282         const 'atype_name` * const restrict pwhich)
 283 {
 284   eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
 285 }
 286
 287
 288 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 289         GFC_INTEGER_4,
 290         const gfc_array_char * const restrict,
 291         const 'atype` * const restrict,
 292         const gfc_array_char * const restrict,
 293         const 'atype_name` * const restrict,
 294         GFC_INTEGER_4, GFC_INTEGER_4);
 295 export_proto(eoshift3_'atype_kind`_char);
 296
 297 void
 298 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 299         GFC_INTEGER_4 ret_length __attribute__((unused)),
 300         const gfc_array_char * const restrict array,
 301         const 'atype` *  const restrict h,
 302         const gfc_array_char * const restrict bound,
 303         const 'atype_name` * const restrict pwhich,
 304         GFC_INTEGER_4 array_length __attribute__((unused)),
 305         GFC_INTEGER_4 bound_length __attribute__((unused)))
 306 {
 307   eoshift3 (ret, array, h, bound, pwhich, " ", 1);
 308 }
 309
 310
 311 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
 312         GFC_INTEGER_4,
 313         const gfc_array_char * const restrict,
 314         const 'atype` * const restrict,
 315         const gfc_array_char * const restrict,
 316         const 'atype_name` * const restrict,
 317         GFC_INTEGER_4, GFC_INTEGER_4);
 318 export_proto(eoshift3_'atype_kind`_char4);
 319
 320 void
 321 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 322         GFC_INTEGER_4 ret_length __attribute__((unused)),
 323         const gfc_array_char * const restrict array,
 324         const 'atype` *  const restrict h,
 325         const gfc_array_char * const restrict bound,
 326         const 'atype_name` * const restrict pwhich,
 327         GFC_INTEGER_4 array_length __attribute__((unused)),
 328         GFC_INTEGER_4 bound_length __attribute__((unused)))
 329 {
 330   static const gfc_char4_t space = (unsigned char) ''` ''`;
 331   eoshift3 (ret, array, h, bound, pwhich,
 332             (const char *) &space, sizeof (gfc_char4_t));
 333 }
 334
 335 #endif'