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->data = internal_malloc_size (size * arraysize);
  94       ret->offset = 0;
  95       ret->dtype = array->dtype;
  96       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  97         {
  98           index_type ub, str;
  99
 100           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
 101
 102           if (i == 0)
 103             str = 1;
 104           else
 105             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
 106               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
 107
 108           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 109
 110         }
 111       if (arraysize > 0)
 112         ret->data = internal_malloc_size (size * arraysize);
 113       else
 114         ret->data = internal_malloc_size (1);
 115
 116     }
 117   else if (unlikely (compile_options.bounds_check))
 118     {
 119       bounds_equal_extents ((array_t *) ret, (array_t *) array,
 120                                  "return value", "EOSHIFT");
 121     }
 122
 123   if (unlikely (compile_options.bounds_check))
 124     {
 125       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
 126                               "SHIFT argument", "EOSHIFT");
 127     }
 128
 129   if (arraysize == 0)
 130     return;
 131
 132   extent[0] = 1;
 133   count[0] = 0;
 134   n = 0;
 135   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 136     {
 137       if (dim == which)
 138         {
 139           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 140           if (roffset == 0)
 141             roffset = size;
 142           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 143           if (soffset == 0)
 144             soffset = size;
 145           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 146         }
 147       else
 148         {
 149           count[n] = 0;
 150           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 151           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 152           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 153
 154           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 155           if (bound)
 156             bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
 157           else
 158             bstride[n] = 0;
 159           n++;
 160         }
 161     }
 162   if (sstride[0] == 0)
 163     sstride[0] = size;
 164   if (rstride[0] == 0)
 165     rstride[0] = size;
 166   if (hstride[0] == 0)
 167     hstride[0] = 1;
 168   if (bound && bstride[0] == 0)
 169     bstride[0] = size;
 170
 171   dim = GFC_DESCRIPTOR_RANK (array);
 172   rstride0 = rstride[0];
 173   sstride0 = sstride[0];
 174   hstride0 = hstride[0];
 175   bstride0 = bstride[0];
 176   rptr = ret->data;
 177   sptr = array->data;
 178   hptr = h->data;
 179   if (bound)
 180     bptr = bound->data;
 181   else
 182     bptr = NULL;
 183
 184   while (rptr)
 185     {
 186       /* Do the shift for this dimension.  */
 187       sh = *hptr;
 188       if (( sh >= 0 ? sh : -sh ) > len)
 189         {
 190           delta = len;
 191           sh = len;
 192         }
 193       else
 194         delta = (sh >= 0) ? sh: -sh;
 195
 196       if (sh > 0)
 197         {
 198           src = &sptr[delta * soffset];
 199           dest = rptr;
 200         }
 201       else
 202         {
 203           src = sptr;
 204           dest = &rptr[delta * roffset];
 205         }
 206       for (n = 0; n < len - delta; n++)
 207         {
 208           memcpy (dest, src, size);
 209           dest += roffset;
 210           src += soffset;
 211         }
 212       if (sh < 0)
 213         dest = rptr;
 214       n = delta;
 215
 216       if (bptr)
 217         while (n--)
 218           {
 219             memcpy (dest, bptr, size);
 220             dest += roffset;
 221           }
 222       else
 223         while (n--)
 224           {
 225             index_type i;
 226
 227             if (filler_len == 1)
 228               memset (dest, filler[0], size);
 229             else
 230               for (i = 0; i < size; i += filler_len)
 231                 memcpy (&dest[i], filler, filler_len);
 232
 233             dest += roffset;
 234           }
 235
 236       /* Advance to the next section.  */
 237       rptr += rstride0;
 238       sptr += sstride0;
 239       hptr += hstride0;
 240       bptr += bstride0;
 241       count[0]++;
 242       n = 0;
 243       while (count[n] == extent[n])
 244         {
 245           /* When we get to the end of a dimension, reset it and increment
 246              the next dimension.  */
 247           count[n] = 0;
 248           /* We could precalculate these products, but this is a less
 249              frequently used path so probably not worth it.  */
 250           rptr -= rstride[n] * extent[n];
 251           sptr -= sstride[n] * extent[n];
 252           hptr -= hstride[n] * extent[n];
 253           bptr -= bstride[n] * extent[n];
 254           n++;
 255           if (n >= dim - 1)
 256             {
 257               /* Break out of the loop.  */
 258               rptr = NULL;
 259               break;
 260             }
 261           else
 262             {
 263               count[n]++;
 264               rptr += rstride[n];
 265               sptr += sstride[n];
 266               hptr += hstride[n];
 267               bptr += bstride[n];
 268             }
 269         }
 270     }
 271 }
 272
 273 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 274         const gfc_array_char * const restrict,
 275         const 'atype` * const restrict,
 276         const gfc_array_char * const restrict,
 277         const 'atype_name` *);
 278 export_proto(eoshift3_'atype_kind`);
 279
 280 void
 281 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 282         const gfc_array_char * const restrict array,
 283         const 'atype` * const restrict h,
 284         const gfc_array_char * const restrict bound,
 285         const 'atype_name` * const restrict pwhich)
 286 {
 287   eoshift3 (ret, array, h, bound, pwhich, "\0", 1);
 288 }
 289
 290
 291 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 292         GFC_INTEGER_4,
 293         const gfc_array_char * const restrict,
 294         const 'atype` * const restrict,
 295         const gfc_array_char * const restrict,
 296         const 'atype_name` * const restrict,
 297         GFC_INTEGER_4, GFC_INTEGER_4);
 298 export_proto(eoshift3_'atype_kind`_char);
 299
 300 void
 301 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 302         GFC_INTEGER_4 ret_length __attribute__((unused)),
 303         const gfc_array_char * const restrict array,
 304         const 'atype` *  const restrict h,
 305         const gfc_array_char * const restrict bound,
 306         const 'atype_name` * const restrict pwhich,
 307         GFC_INTEGER_4 array_length __attribute__((unused)),
 308         GFC_INTEGER_4 bound_length __attribute__((unused)))
 309 {
 310   eoshift3 (ret, array, h, bound, pwhich, " ", 1);
 311 }
 312
 313
 314 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
 315         GFC_INTEGER_4,
 316         const gfc_array_char * const restrict,
 317         const 'atype` * const restrict,
 318         const gfc_array_char * const restrict,
 319         const 'atype_name` * const restrict,
 320         GFC_INTEGER_4, GFC_INTEGER_4);
 321 export_proto(eoshift3_'atype_kind`_char4);
 322
 323 void
 324 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 325         GFC_INTEGER_4 ret_length __attribute__((unused)),
 326         const gfc_array_char * const restrict array,
 327         const 'atype` *  const restrict h,
 328         const gfc_array_char * const restrict bound,
 329         const 'atype_name` * const restrict pwhich,
 330         GFC_INTEGER_4 array_length __attribute__((unused)),
 331         GFC_INTEGER_4 bound_length __attribute__((unused)))
 332 {
 333   static const gfc_char4_t space = (unsigned char) ''` ''`;
 334   eoshift3 (ret, array, h, bound, pwhich,
 335             (const char *) &space, sizeof (gfc_char4_t));
 336 }
 337
 338 #endif'