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