libgfortran/m4/eoshift3.m4

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