libgfortran/m4/eoshift1.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 eoshift1 (gfc_array_char * const restrict ret,
  37         const gfc_array_char * const restrict array,
  38         const 'atype` * const restrict h,
  39         const char * const restrict pbound,
  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
  60   index_type count[GFC_MAX_DIMENSIONS];
  61   index_type extent[GFC_MAX_DIMENSIONS];
  62   index_type dim;
  63   index_type len;
  64   index_type n;
  65   index_type size;
  66   index_type arraysize;
  67   int which;
  68   'atype_name` sh;
  69   'atype_name` delta;
  70
  71   /* The compiler cannot figure out that these are set, initialize
  72      them to avoid warnings.  */
  73   len = 0;
  74   soffset = 0;
  75   roffset = 0;
  76
  77   size = GFC_DESCRIPTOR_SIZE(array);
  78
  79   if (pwhich)
  80     which = *pwhich - 1;
  81   else
  82     which = 0;
  83
  84   extent[0] = 1;
  85   count[0] = 0;
  86
  87   arraysize = size0 ((array_t *) array);
  88   if (ret->data == NULL)
  89     {
  90       int i;
  91
  92       ret->data = internal_malloc_size (size * arraysize);
  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   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           n++;
 153         }
 154     }
 155   if (sstride[0] == 0)
 156     sstride[0] = size;
 157   if (rstride[0] == 0)
 158     rstride[0] = size;
 159   if (hstride[0] == 0)
 160     hstride[0] = 1;
 161
 162   dim = GFC_DESCRIPTOR_RANK (array);
 163   rstride0 = rstride[0];
 164   sstride0 = sstride[0];
 165   hstride0 = hstride[0];
 166   rptr = ret->data;
 167   sptr = array->data;
 168   hptr = h->data;
 169
 170   while (rptr)
 171     {
 172       /* Do the shift for this dimension.  */
 173       sh = *hptr;
 174       if (( sh >= 0 ? sh : -sh ) > len)
 175         {
 176           delta = len;
 177           sh = len;
 178         }
 179       else
 180         delta = (sh >= 0) ? sh: -sh;
 181
 182       if (sh > 0)
 183         {
 184           src = &sptr[delta * soffset];
 185           dest = rptr;
 186         }
 187       else
 188         {
 189           src = sptr;
 190           dest = &rptr[delta * roffset];
 191         }
 192       for (n = 0; n < len - delta; n++)
 193         {
 194           memcpy (dest, src, size);
 195           dest += roffset;
 196           src += soffset;
 197         }
 198       if (sh < 0)
 199         dest = rptr;
 200       n = delta;
 201
 202       if (pbound)
 203         while (n--)
 204           {
 205             memcpy (dest, pbound, size);
 206             dest += roffset;
 207           }
 208       else
 209         while (n--)
 210           {
 211             index_type i;
 212
 213             if (filler_len == 1)
 214               memset (dest, filler[0], size);
 215             else
 216               for (i = 0; i < size; i += filler_len)
 217                 memcpy (&dest[i], filler, filler_len);
 218
 219             dest += roffset;
 220           }
 221
 222       /* Advance to the next section.  */
 223       rptr += rstride0;
 224       sptr += sstride0;
 225       hptr += hstride0;
 226       count[0]++;
 227       n = 0;
 228       while (count[n] == extent[n])
 229         {
 230           /* When we get to the end of a dimension, reset it and increment
 231              the next dimension.  */
 232           count[n] = 0;
 233           /* We could precalculate these products, but this is a less
 234              frequently used path so probably not worth it.  */
 235           rptr -= rstride[n] * extent[n];
 236           sptr -= sstride[n] * extent[n];
 237           hptr -= hstride[n] * extent[n];
 238           n++;
 239           if (n >= dim - 1)
 240             {
 241               /* Break out of the loop.  */
 242               rptr = NULL;
 243               break;
 244             }
 245           else
 246             {
 247               count[n]++;
 248               rptr += rstride[n];
 249               sptr += sstride[n];
 250               hptr += hstride[n];
 251             }
 252         }
 253     }
 254 }
 255
 256 void eoshift1_'atype_kind` (gfc_array_char * const restrict,
 257         const gfc_array_char * const restrict,
 258         const 'atype` * const restrict, const char * const restrict,
 259         const 'atype_name` * const restrict);
 260 export_proto(eoshift1_'atype_kind`);
 261
 262 void
 263 eoshift1_'atype_kind` (gfc_array_char * const restrict ret,
 264         const gfc_array_char * const restrict array,
 265         const 'atype` * const restrict h,
 266         const char * const restrict pbound,
 267         const 'atype_name` * const restrict pwhich)
 268 {
 269   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 270 }
 271
 272
 273 void eoshift1_'atype_kind`_char (gfc_array_char * const restrict,
 274         GFC_INTEGER_4,
 275         const gfc_array_char * const restrict,
 276         const 'atype` * const restrict,
 277         const char * const restrict,
 278         const 'atype_name` * const restrict,
 279         GFC_INTEGER_4, GFC_INTEGER_4);
 280 export_proto(eoshift1_'atype_kind`_char);
 281
 282 void
 283 eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 284         GFC_INTEGER_4 ret_length __attribute__((unused)),
 285         const gfc_array_char * const restrict array,
 286         const 'atype` * const restrict h,
 287         const char *  const restrict pbound,
 288         const 'atype_name` * const restrict pwhich,
 289         GFC_INTEGER_4 array_length __attribute__((unused)),
 290         GFC_INTEGER_4 bound_length __attribute__((unused)))
 291 {
 292   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 293 }
 294
 295
 296 void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict,
 297         GFC_INTEGER_4,
 298         const gfc_array_char * const restrict,
 299         const 'atype` * const restrict,
 300         const char * const restrict,
 301         const 'atype_name` * const restrict,
 302         GFC_INTEGER_4, GFC_INTEGER_4);
 303 export_proto(eoshift1_'atype_kind`_char4);
 304
 305 void
 306 eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 307         GFC_INTEGER_4 ret_length __attribute__((unused)),
 308         const gfc_array_char * const restrict array,
 309         const 'atype` * const restrict h,
 310         const char *  const restrict pbound,
 311         const 'atype_name` * const restrict pwhich,
 312         GFC_INTEGER_4 array_length __attribute__((unused)),
 313         GFC_INTEGER_4 bound_length __attribute__((unused)))
 314 {
 315   static const gfc_char4_t space = (unsigned char) ''` ''`;
 316   eoshift1 (ret, array, h, pbound, pwhich,
 317             (const char *) &space, sizeof (gfc_char4_t));
 318 }
 319
 320 #endif'