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