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   int which;
  67   'atype_name` sh;
  68   'atype_name` delta;
  69
  70   /* The compiler cannot figure out that these are set, initialize
  71      them to avoid warnings.  */
  72   len = 0;
  73   soffset = 0;
  74   roffset = 0;
  75
  76   size = GFC_DESCRIPTOR_SIZE(array);
  77
  78   if (pwhich)
  79     which = *pwhich - 1;
  80   else
  81     which = 0;
  82
  83   extent[0] = 1;
  84   count[0] = 0;
  85
  86   if (ret->data == NULL)
  87     {
  88       int i;
  89
  90       ret->data = internal_malloc_size (size * size0 ((array_t *)array));
  91       ret->offset = 0;
  92       ret->dtype = array->dtype;
  93       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  94         {
  95           index_type ub, str;
  96
  97           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  98
  99           if (i == 0)
 100             str = 1;
 101           else
 102             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
 103               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
 104
 105           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 106
 107         }
 108     }
 109   else
 110     {
 111       if (size0 ((array_t *) ret) == 0)
 112         return;
 113     }
 114
 115   n = 0;
 116   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 117     {
 118       if (dim == which)
 119         {
 120           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 121           if (roffset == 0)
 122             roffset = size;
 123           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 124           if (soffset == 0)
 125             soffset = size;
 126           len = GFC_DESCRIPTOR_EXTENT(array,dim);
 127         }
 128       else
 129         {
 130           count[n] = 0;
 131           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 132           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 133           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 134
 135           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
 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
 146   dim = GFC_DESCRIPTOR_RANK (array);
 147   rstride0 = rstride[0];
 148   sstride0 = sstride[0];
 149   hstride0 = hstride[0];
 150   rptr = ret->data;
 151   sptr = array->data;
 152   hptr = h->data;
 153
 154   while (rptr)
 155     {
 156       /* Do the shift for this dimension.  */
 157       sh = *hptr;
 158       if (( sh >= 0 ? sh : -sh ) > len)
 159         {
 160           delta = len;
 161           sh = len;
 162         }
 163       else
 164         delta = (sh >= 0) ? sh: -sh;
 165
 166       if (sh > 0)
 167         {
 168           src = &sptr[delta * soffset];
 169           dest = rptr;
 170         }
 171       else
 172         {
 173           src = sptr;
 174           dest = &rptr[delta * roffset];
 175         }
 176       for (n = 0; n < len - delta; n++)
 177         {
 178           memcpy (dest, src, size);
 179           dest += roffset;
 180           src += soffset;
 181         }
 182       if (sh < 0)
 183         dest = rptr;
 184       n = delta;
 185
 186       if (pbound)
 187         while (n--)
 188           {
 189             memcpy (dest, pbound, size);
 190             dest += roffset;
 191           }
 192       else
 193         while (n--)
 194           {
 195             index_type i;
 196
 197             if (filler_len == 1)
 198               memset (dest, filler[0], size);
 199             else
 200               for (i = 0; i < size; i += filler_len)
 201                 memcpy (&dest[i], filler, filler_len);
 202
 203             dest += roffset;
 204           }
 205
 206       /* Advance to the next section.  */
 207       rptr += rstride0;
 208       sptr += sstride0;
 209       hptr += hstride0;
 210       count[0]++;
 211       n = 0;
 212       while (count[n] == extent[n])
 213         {
 214           /* When we get to the end of a dimension, reset it and increment
 215              the next dimension.  */
 216           count[n] = 0;
 217           /* We could precalculate these products, but this is a less
 218              frequently used path so probably not worth it.  */
 219           rptr -= rstride[n] * extent[n];
 220           sptr -= sstride[n] * extent[n];
 221           hptr -= hstride[n] * extent[n];
 222           n++;
 223           if (n >= dim - 1)
 224             {
 225               /* Break out of the loop.  */
 226               rptr = NULL;
 227               break;
 228             }
 229           else
 230             {
 231               count[n]++;
 232               rptr += rstride[n];
 233               sptr += sstride[n];
 234               hptr += hstride[n];
 235             }
 236         }
 237     }
 238 }
 239
 240 void eoshift1_'atype_kind` (gfc_array_char * const restrict,
 241         const gfc_array_char * const restrict,
 242         const 'atype` * const restrict, const char * const restrict,
 243         const 'atype_name` * const restrict);
 244 export_proto(eoshift1_'atype_kind`);
 245
 246 void
 247 eoshift1_'atype_kind` (gfc_array_char * const restrict ret,
 248         const gfc_array_char * const restrict array,
 249         const 'atype` * const restrict h,
 250         const char * const restrict pbound,
 251         const 'atype_name` * const restrict pwhich)
 252 {
 253   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
 254 }
 255
 256
 257 void eoshift1_'atype_kind`_char (gfc_array_char * const restrict,
 258         GFC_INTEGER_4,
 259         const gfc_array_char * const restrict,
 260         const 'atype` * const restrict,
 261         const char * const restrict,
 262         const 'atype_name` * const restrict,
 263         GFC_INTEGER_4, GFC_INTEGER_4);
 264 export_proto(eoshift1_'atype_kind`_char);
 265
 266 void
 267 eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
 268         GFC_INTEGER_4 ret_length __attribute__((unused)),
 269         const gfc_array_char * const restrict array,
 270         const 'atype` * const restrict h,
 271         const char *  const restrict pbound,
 272         const 'atype_name` * const restrict pwhich,
 273         GFC_INTEGER_4 array_length __attribute__((unused)),
 274         GFC_INTEGER_4 bound_length __attribute__((unused)))
 275 {
 276   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
 277 }
 278
 279
 280 void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict,
 281         GFC_INTEGER_4,
 282         const gfc_array_char * const restrict,
 283         const 'atype` * const restrict,
 284         const char * const restrict,
 285         const 'atype_name` * const restrict,
 286         GFC_INTEGER_4, GFC_INTEGER_4);
 287 export_proto(eoshift1_'atype_kind`_char4);
 288
 289 void
 290 eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
 291         GFC_INTEGER_4 ret_length __attribute__((unused)),
 292         const gfc_array_char * const restrict array,
 293         const 'atype` * const restrict h,
 294         const char *  const restrict pbound,
 295         const 'atype_name` * const restrict pwhich,
 296         GFC_INTEGER_4 array_length __attribute__((unused)),
 297         GFC_INTEGER_4 bound_length __attribute__((unused)))
 298 {
 299   static const gfc_char4_t space = (unsigned char) ''` ''`;
 300   eoshift1 (ret, array, h, pbound, pwhich,
 301             (const char *) &space, sizeof (gfc_char4_t));
 302 }
 303
 304 #endif'