libgfortran/m4/eoshift3.m4

   1 `/* Implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005, 2007 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>'
  35
  36 include(iparm.m4)dnl
  37
  38 `#if defined (HAVE_'atype_name`)
  39
  40 static void
  41 eoshift3 (gfc_array_char * const restrict ret,
  42         const gfc_array_char * const restrict array,
  43         const 'atype` * const restrict h,
  44         const gfc_array_char * const restrict bound,
  45         const 'atype_name` * const restrict pwhich,
  46         index_type size, const char * filler, index_type filler_len)
  47 {
  48   /* r.* indicates the return array.  */
  49   index_type rstride[GFC_MAX_DIMENSIONS];
  50   index_type rstride0;
  51   index_type roffset;
  52   char *rptr;
  53   char * restrict dest;
  54   /* s.* indicates the source array.  */
  55   index_type sstride[GFC_MAX_DIMENSIONS];
  56   index_type sstride0;
  57   index_type soffset;
  58   const char *sptr;
  59   const char *src;
  60   /* h.* indicates the shift array.  */
  61   index_type hstride[GFC_MAX_DIMENSIONS];
  62   index_type hstride0;
  63   const 'atype_name` *hptr;
  64   /* b.* indicates the bound array.  */
  65   index_type bstride[GFC_MAX_DIMENSIONS];
  66   index_type bstride0;
  67   const char *bptr;
  68
  69   index_type count[GFC_MAX_DIMENSIONS];
  70   index_type extent[GFC_MAX_DIMENSIONS];
  71   index_type dim;
  72   index_type len;
  73   index_type n;
  74   int which;
  75   'atype_name` sh;
  76   'atype_name` delta;
  77
  78   /* The compiler cannot figure out that these are set, initialize
  79      them to avoid warnings.  */
  80   len = 0;
  81   soffset = 0;
  82   roffset = 0;
  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 * size0 ((array_t *)array));
  94       ret->offset = 0;
  95       ret->dtype = array->dtype;
  96       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  97         {
  98           ret->dim[i].lbound = 0;
  99           ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;
 100
 101           if (i == 0)
 102             ret->dim[i].stride = 1;
 103           else
 104             ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
 105         }
 106     }
 107
 108
 109   extent[0] = 1;
 110   count[0] = 0;
 111   n = 0;
 112   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 113     {
 114       if (dim == which)
 115         {
 116           roffset = ret->dim[dim].stride * size;
 117           if (roffset == 0)
 118             roffset = size;
 119           soffset = array->dim[dim].stride * size;
 120           if (soffset == 0)
 121             soffset = size;
 122           len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 123         }
 124       else
 125         {
 126           count[n] = 0;
 127           extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 128           rstride[n] = ret->dim[dim].stride * size;
 129           sstride[n] = array->dim[dim].stride * size;
 130
 131           hstride[n] = h->dim[n].stride;
 132           if (bound)
 133             bstride[n] = bound->dim[n].stride * size;
 134           else
 135             bstride[n] = 0;
 136           n++;
 137         }
 138     }
 139   if (sstride[0] == 0)
 140     sstride[0] = size;
 141   if (rstride[0] == 0)
 142     rstride[0] = size;
 143   if (hstride[0] == 0)
 144     hstride[0] = 1;
 145   if (bound && bstride[0] == 0)
 146     bstride[0] = size;
 147
 148   dim = GFC_DESCRIPTOR_RANK (array);
 149   rstride0 = rstride[0];
 150   sstride0 = sstride[0];
 151   hstride0 = hstride[0];
 152   bstride0 = bstride[0];
 153   rptr = ret->data;
 154   sptr = array->data;
 155   hptr = h->data;
 156   if (bound)
 157     bptr = bound->data;
 158   else
 159     bptr = NULL;
 160
 161   while (rptr)
 162     {
 163       /* Do the shift for this dimension.  */
 164       sh = *hptr;
 165       if (( sh >= 0 ? sh : -sh ) > len)
 166         {
 167           delta = len;
 168           sh = len;
 169         }
 170       else
 171         delta = (sh >= 0) ? sh: -sh;
 172
 173       if (sh > 0)
 174         {
 175           src = &sptr[delta * soffset];
 176           dest = rptr;
 177         }
 178       else
 179         {
 180           src = sptr;
 181           dest = &rptr[delta * roffset];
 182         }
 183       for (n = 0; n < len - delta; n++)
 184         {
 185           memcpy (dest, src, size);
 186           dest += roffset;
 187           src += soffset;
 188         }
 189       if (sh < 0)
 190         dest = rptr;
 191       n = delta;
 192
 193       if (bptr)
 194         while (n--)
 195           {
 196             memcpy (dest, bptr, size);
 197             dest += roffset;
 198           }
 199       else
 200         while (n--)
 201           {
 202             index_type i;
 203
 204             if (filler_len == 1)
 205               memset (dest, filler[0], size);
 206             else
 207               for (i = 0; i < size; i += filler_len)
 208                 memcpy (&dest[i], filler, filler_len);
 209
 210             dest += roffset;
 211           }
 212
 213       /* Advance to the next section.  */
 214       rptr += rstride0;
 215       sptr += sstride0;
 216       hptr += hstride0;
 217       bptr += bstride0;
 218       count[0]++;
 219       n = 0;
 220       while (count[n] == extent[n])
 221         {
 222           /* When we get to the end of a dimension, reset it and increment
 223              the next dimension.  */
 224           count[n] = 0;
 225           /* We could precalculate these products, but this is a less
 226              frequently used path so probably not worth it.  */
 227           rptr -= rstride[n] * extent[n];
 228           sptr -= sstride[n] * extent[n];
 229           hptr -= hstride[n] * extent[n];
 230           bptr -= bstride[n] * extent[n];
 231           n++;
 232           if (n >= dim - 1)
 233             {
 234               /* Break out of the loop.  */
 235               rptr = NULL;
 236               break;
 237             }
 238           else
 239             {
 240               count[n]++;
 241               rptr += rstride[n];
 242               sptr += sstride[n];
 243               hptr += hstride[n];
 244               bptr += bstride[n];
 245             }
 246         }
 247     }
 248 }
 249
 250 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 251         const gfc_array_char * const restrict,
 252         const 'atype` * const restrict,
 253         const gfc_array_char * const restrict,
 254         const 'atype_name` *);
 255 export_proto(eoshift3_'atype_kind`);
 256
 257 void
 258 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 259         const gfc_array_char * const restrict array,
 260         const 'atype` * const restrict h,
 261         const gfc_array_char * const restrict bound,
 262         const 'atype_name` * const restrict pwhich)
 263 {
 264   eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array),
 265             "\0", 1);
 266 }
 267
 268
 269 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 270         GFC_INTEGER_4,
 271         const gfc_array_char * const restrict,
 272         const 'atype` * const restrict,
 273         const gfc_array_char * const restrict,
 274         const 'atype_name` * const restrict,
 275         GFC_INTEGER_4, GFC_INTEGER_4);
 276 export_proto(eoshift3_'atype_kind`_char);
 277
 278 void
 279 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 280         GFC_INTEGER_4 ret_length __attribute__((unused)),
 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         GFC_INTEGER_4 array_length,
 286         GFC_INTEGER_4 bound_length __attribute__((unused)))
 287 {
 288   eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1);
 289 }
 290
 291
 292 extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict,
 293         GFC_INTEGER_4,
 294         const gfc_array_char * const restrict,
 295         const 'atype` * const restrict,
 296         const gfc_array_char * const restrict,
 297         const 'atype_name` * const restrict,
 298         GFC_INTEGER_4, GFC_INTEGER_4);
 299 export_proto(eoshift3_'atype_kind`_char4);
 300
 301 void
 302 eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 303         GFC_INTEGER_4 ret_length __attribute__((unused)),
 304         const gfc_array_char * const restrict array,
 305         const 'atype` *  const restrict h,
 306         const gfc_array_char * const restrict bound,
 307         const 'atype_name` * const restrict pwhich,
 308         GFC_INTEGER_4 array_length,
 309         GFC_INTEGER_4 bound_length __attribute__((unused)))
 310 {
 311   static const gfc_char4_t space = (unsigned char) ''` ''`;
 312   eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t),
 313             (const char *) &space, sizeof (gfc_char4_t));
 314 }
 315
 316 #endif'