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