libgfortran/m4/reshape.m4

   1 `/* Implementation of the RESHAPE
   2    Copyright 2002, 2006, 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
  35 include(iparm.m4)dnl
  36
  37 `#if defined (HAVE_'rtype_name`)
  38
  39 typedef GFC_ARRAY_DESCRIPTOR(1, 'index_type`) 'shape_type`;'
  40
  41 dnl For integer routines, only the kind (ie size) is used to name the
  42 dnl function.  The same function will be used for integer and logical
  43 dnl arrays of the same kind.
  44
  45 `extern void reshape_'rtype_ccode` ('rtype` * const restrict,
  46         'rtype` * const restrict,
  47         'shape_type` * const restrict,
  48         'rtype` * const restrict,
  49         'shape_type` * const restrict);
  50 export_proto(reshape_'rtype_ccode`);
  51
  52 void
  53 reshape_'rtype_ccode` ('rtype` * const restrict ret,
  54         'rtype` * const restrict source,
  55         'shape_type` * const restrict shape,
  56         'rtype` * const restrict pad,
  57         'shape_type` * const restrict order)
  58 {
  59   /* r.* indicates the return array.  */
  60   index_type rcount[GFC_MAX_DIMENSIONS];
  61   index_type rextent[GFC_MAX_DIMENSIONS];
  62   index_type rstride[GFC_MAX_DIMENSIONS];
  63   index_type rstride0;
  64   index_type rdim;
  65   index_type rsize;
  66   index_type rs;
  67   index_type rex;
  68   'rtype_name` *rptr;
  69   /* s.* indicates the source array.  */
  70   index_type scount[GFC_MAX_DIMENSIONS];
  71   index_type sextent[GFC_MAX_DIMENSIONS];
  72   index_type sstride[GFC_MAX_DIMENSIONS];
  73   index_type sstride0;
  74   index_type sdim;
  75   index_type ssize;
  76   const 'rtype_name` *sptr;
  77   /* p.* indicates the pad array.  */
  78   index_type pcount[GFC_MAX_DIMENSIONS];
  79   index_type pextent[GFC_MAX_DIMENSIONS];
  80   index_type pstride[GFC_MAX_DIMENSIONS];
  81   index_type pdim;
  82   index_type psize;
  83   const 'rtype_name` *pptr;
  84
  85   const 'rtype_name` *src;
  86   int n;
  87   int dim;
  88   int sempty, pempty, shape_empty;
  89   index_type shape_data[GFC_MAX_DIMENSIONS];
  90
  91   rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  92   if (rdim != GFC_DESCRIPTOR_RANK(ret))
  93     runtime_error("rank of return array incorrect in RESHAPE intrinsic");
  94
  95   shape_empty = 0;
  96
  97   for (n = 0; n < rdim; n++)
  98     {
  99       shape_data[n] = shape->data[n * shape->dim[0].stride];
 100       if (shape_data[n] <= 0)
 101       {
 102         shape_data[n] = 0;
 103         shape_empty = 1;
 104       }
 105     }
 106
 107   if (ret->data == NULL)
 108     {
 109       rs = 1;
 110       for (n = 0; n < rdim; n++)
 111         {
 112           ret->dim[n].lbound = 0;
 113           rex = shape_data[n];
 114           ret->dim[n].ubound =  rex - 1;
 115           ret->dim[n].stride = rs;
 116           rs *= rex;
 117         }
 118       ret->offset = 0;
 119       ret->data = internal_malloc_size ( rs * sizeof ('rtype_name`));
 120       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
 121     }
 122
 123   if (shape_empty)
 124     return;
 125
 126   if (unlikely (compile_options.bounds_check))
 127     {
 128       if (order)
 129         {
 130           int seen[GFC_MAX_DIMENSIONS];
 131           index_type v;
 132
 133           for (n = 0; n < rdim; n++)
 134             seen[n] = 0;
 135
 136           for (n = 0; n < rdim; n++)
 137             {
 138               v = order->data[n * order->dim[0].stride] - 1;
 139
 140               if (v < 0 || v >= rdim)
 141                 runtime_error("Value %ld out of range in ORDER argument"
 142                               " to RESHAPE intrinsic", (long int) v + 1);
 143
 144               if (seen[v] != 0)
 145                 runtime_error("Duplicate value %ld in ORDER argument to"
 146                               " RESHAPE intrinsic", (long int) v + 1);
 147
 148               seen[v] = 1;
 149             }
 150         }
 151     }
 152
 153   rsize = 1;
 154   for (n = 0; n < rdim; n++)
 155     {
 156       if (order)
 157         dim = order->data[n * order->dim[0].stride] - 1;
 158       else
 159         dim = n;
 160
 161       rcount[n] = 0;
 162       rstride[n] = ret->dim[dim].stride;
 163       rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
 164       if (rextent[n] < 0)
 165         rextent[n] = 0;
 166
 167       if (rextent[n] != shape_data[dim])
 168         runtime_error ("shape and target do not conform");
 169
 170       if (rsize == rstride[n])
 171         rsize *= rextent[n];
 172       else
 173         rsize = 0;
 174       if (rextent[n] <= 0)
 175         return;
 176     }
 177
 178   sdim = GFC_DESCRIPTOR_RANK (source);
 179   ssize = 1;
 180   sempty = 0;
 181   for (n = 0; n < sdim; n++)
 182     {
 183       scount[n] = 0;
 184       sstride[n] = source->dim[n].stride;
 185       sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
 186       if (sextent[n] <= 0)
 187         {
 188           sempty = 1;
 189           sextent[n] = 0;
 190         }
 191
 192       if (ssize == sstride[n])
 193         ssize *= sextent[n];
 194       else
 195         ssize = 0;
 196     }
 197
 198   if (pad)
 199     {
 200       pdim = GFC_DESCRIPTOR_RANK (pad);
 201       psize = 1;
 202       pempty = 0;
 203       for (n = 0; n < pdim; n++)
 204         {
 205           pcount[n] = 0;
 206           pstride[n] = pad->dim[n].stride;
 207           pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
 208           if (pextent[n] <= 0)
 209             {
 210               pempty = 1;
 211               pextent[n] = 0;
 212             }
 213
 214           if (psize == pstride[n])
 215             psize *= pextent[n];
 216           else
 217             psize = 0;
 218         }
 219       pptr = pad->data;
 220     }
 221   else
 222     {
 223       pdim = 0;
 224       psize = 1;
 225       pempty = 1;
 226       pptr = NULL;
 227     }
 228
 229   if (rsize != 0 && ssize != 0 && psize != 0)
 230     {
 231       rsize *= sizeof ('rtype_name`);
 232       ssize *= sizeof ('rtype_name`);
 233       psize *= sizeof ('rtype_name`);
 234       reshape_packed ((char *)ret->data, rsize, (char *)source->data,
 235                       ssize, pad ? (char *)pad->data : NULL, psize);
 236       return;
 237     }
 238   rptr = ret->data;
 239   src = sptr = source->data;
 240   rstride0 = rstride[0];
 241   sstride0 = sstride[0];
 242
 243   if (sempty && pempty)
 244     abort ();
 245
 246   if (sempty)
 247     {
 248       /* Switch immediately to the pad array.  */
 249       src = pptr;
 250       sptr = NULL;
 251       sdim = pdim;
 252       for (dim = 0; dim < pdim; dim++)
 253         {
 254           scount[dim] = pcount[dim];
 255           sextent[dim] = pextent[dim];
 256           sstride[dim] = pstride[dim];
 257           sstride0 = sstride[0] * sizeof ('rtype_name`);
 258         }
 259     }
 260
 261   while (rptr)
 262     {
 263       /* Select between the source and pad arrays.  */
 264       *rptr = *src;
 265       /* Advance to the next element.  */
 266       rptr += rstride0;
 267       src += sstride0;
 268       rcount[0]++;
 269       scount[0]++;
 270
 271       /* Advance to the next destination element.  */
 272       n = 0;
 273       while (rcount[n] == rextent[n])
 274         {
 275           /* When we get to the end of a dimension, reset it and increment
 276              the next dimension.  */
 277           rcount[n] = 0;
 278           /* We could precalculate these products, but this is a less
 279              frequently used path so probably not worth it.  */
 280           rptr -= rstride[n] * rextent[n];
 281           n++;
 282           if (n == rdim)
 283             {
 284               /* Break out of the loop.  */
 285               rptr = NULL;
 286               break;
 287             }
 288           else
 289             {
 290               rcount[n]++;
 291               rptr += rstride[n];
 292             }
 293         }
 294       /* Advance to the next source element.  */
 295       n = 0;
 296       while (scount[n] == sextent[n])
 297         {
 298           /* When we get to the end of a dimension, reset it and increment
 299              the next dimension.  */
 300           scount[n] = 0;
 301           /* We could precalculate these products, but this is a less
 302              frequently used path so probably not worth it.  */
 303           src -= sstride[n] * sextent[n];
 304           n++;
 305           if (n == sdim)
 306             {
 307               if (sptr && pad)
 308                 {
 309                   /* Switch to the pad array.  */
 310                   sptr = NULL;
 311                   sdim = pdim;
 312                   for (dim = 0; dim < pdim; dim++)
 313                     {
 314                       scount[dim] = pcount[dim];
 315                       sextent[dim] = pextent[dim];
 316                       sstride[dim] = pstride[dim];
 317                       sstride0 = sstride[0];
 318                     }
 319                 }
 320               /* We now start again from the beginning of the pad array.  */
 321               src = pptr;
 322               break;
 323             }
 324           else
 325             {
 326               scount[n]++;
 327               src += sstride[n];
 328             }
 329         }
 330     }
 331 }
 332
 333 #endif'