libgfortran/m4/eoshift3.m4

   1 `/* Implementation of the EOSHIFT intrinsic
   2    Copyright 2002, 2005 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 "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <string.h>
  35 #include "libgfortran.h"'
  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, char filler)
  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 *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             memset (dest, filler, size);
 203             dest += roffset;
 204           }
 205
 206       /* Advance to the next section.  */
 207       rptr += rstride0;
 208       sptr += sstride0;
 209       hptr += hstride0;
 210       bptr += bstride0;
 211       count[0]++;
 212       n = 0;
 213       while (count[n] == extent[n])
 214         {
 215           /* When we get to the end of a dimension, reset it and increment
 216              the next dimension.  */
 217           count[n] = 0;
 218           /* We could precalculate these products, but this is a less
 219              frequently used path so probably not worth it.  */
 220           rptr -= rstride[n] * extent[n];
 221           sptr -= sstride[n] * extent[n];
 222           hptr -= hstride[n] * extent[n];
 223           bptr -= bstride[n] * extent[n];
 224           n++;
 225           if (n >= dim - 1)
 226             {
 227               /* Break out of the loop.  */
 228               rptr = NULL;
 229               break;
 230             }
 231           else
 232             {
 233               count[n]++;
 234               rptr += rstride[n];
 235               sptr += sstride[n];
 236               hptr += hstride[n];
 237               bptr += bstride[n];
 238             }
 239         }
 240     }
 241 }
 242
 243 extern void eoshift3_'atype_kind` (gfc_array_char * const restrict,
 244         const gfc_array_char * const restrict,
 245         const 'atype` * const restrict,
 246         const gfc_array_char * const restrict,
 247         const 'atype_name` *);
 248 export_proto(eoshift3_'atype_kind`);
 249
 250 void
 251 eoshift3_'atype_kind` (gfc_array_char * const restrict ret,
 252         const gfc_array_char * const restrict array,
 253         const 'atype` * const restrict h,
 254         const gfc_array_char * const restrict bound,
 255         const 'atype_name` * const restrict pwhich)
 256 {
 257   eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
 258 }
 259
 260 extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict,
 261         GFC_INTEGER_4,
 262         const gfc_array_char * const restrict,
 263         const 'atype` * const restrict,
 264         const gfc_array_char * const restrict,
 265         const 'atype_name` * const restrict,
 266         GFC_INTEGER_4, GFC_INTEGER_4);
 267 export_proto(eoshift3_'atype_kind`_char);
 268
 269 void
 270 eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret,
 271         GFC_INTEGER_4 ret_length __attribute__((unused)),
 272         const gfc_array_char * const restrict array,
 273         const 'atype` *  const restrict h,
 274         const gfc_array_char * const restrict bound,
 275         const 'atype_name` * const restrict pwhich,
 276         GFC_INTEGER_4 array_length,
 277         GFC_INTEGER_4 bound_length __attribute__((unused)))
 278 {
 279   eoshift3 (ret, array, h, bound, pwhich, array_length, ''` ''`);
 280 }
 281
 282 #endif'