Home | History | Annotate | Line # | Download | only in m4 
      1      1.1  mrg `/* Helper function for repacking arrays.
      2  1.1.1.3  mrg    Copyright (C) 2003-2022 Free Software Foundation, Inc.
      3      1.1  mrg    Contributed by Paul Brook <paul (a] nowt.org>
      4      1.1  mrg 
      5      1.1  mrg This file is part of the GNU Fortran runtime library (libgfortran).
      6      1.1  mrg 
      7      1.1  mrg Libgfortran is free software; you can redistribute it and/or
      8      1.1  mrg modify it under the terms of the GNU General Public
      9      1.1  mrg License as published by the Free Software Foundation; either
     10      1.1  mrg version 3 of the License, or (at your option) any later version.
     11      1.1  mrg 
     12      1.1  mrg Libgfortran is distributed in the hope that it will be useful,
     13      1.1  mrg but WITHOUT ANY WARRANTY; without even the implied warranty of
     14      1.1  mrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15      1.1  mrg GNU General Public License for more details.
     16      1.1  mrg 
     17      1.1  mrg Under Section 7 of GPL version 3, you are granted additional
     18      1.1  mrg permissions described in the GCC Runtime Library Exception, version
     19      1.1  mrg 3.1, as published by the Free Software Foundation.
     20      1.1  mrg 
     21      1.1  mrg You should have received a copy of the GNU General Public License and
     22      1.1  mrg a copy of the GCC Runtime Library Exception along with this program;
     23      1.1  mrg see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     24      1.1  mrg <http://www.gnu.org/licenses/>.  */
     25      1.1  mrg 
     26      1.1  mrg #include "libgfortran.h"'
     27      1.1  mrg 
     28      1.1  mrg include(iparm.m4)dnl
     29      1.1  mrg 
     30      1.1  mrg `#if defined (HAVE_'rtype_name`)
     31      1.1  mrg 
     32      1.1  mrg /* Allocates a block of memory with internal_malloc if the array needs
     33      1.1  mrg    repacking.  */
     34      1.1  mrg '
     35      1.1  mrg dnl The kind (ie size) is used to name the function for logicals, integers
     36      1.1  mrg dnl and reals.  For complex, it's c4 or c8.
     37      1.1  mrg rtype_name` *
     38      1.1  mrg internal_pack_'rtype_ccode` ('rtype` * source)
     39      1.1  mrg {
     40      1.1  mrg   index_type count[GFC_MAX_DIMENSIONS];
     41      1.1  mrg   index_type extent[GFC_MAX_DIMENSIONS];
     42      1.1  mrg   index_type stride[GFC_MAX_DIMENSIONS];
     43      1.1  mrg   index_type stride0;
     44      1.1  mrg   index_type dim;
     45      1.1  mrg   index_type ssize;
     46      1.1  mrg   const 'rtype_name` *src;
     47      1.1  mrg   'rtype_name` * restrict dest;
     48      1.1  mrg   'rtype_name` *destptr;
     49      1.1  mrg   int packed;
     50      1.1  mrg 
     51      1.1  mrg   /* TODO: Investigate how we can figure out if this is a temporary
     52      1.1  mrg      since the stride=0 thing has been removed from the frontend.  */
     53      1.1  mrg 
     54      1.1  mrg   dim = GFC_DESCRIPTOR_RANK (source);
     55      1.1  mrg   ssize = 1;
     56      1.1  mrg   packed = 1;
     57      1.1  mrg   for (index_type n = 0; n < dim; n++)
     58      1.1  mrg     {
     59      1.1  mrg       count[n] = 0;
     60      1.1  mrg       stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
     61      1.1  mrg       extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
     62      1.1  mrg       if (extent[n] <= 0)
     63      1.1  mrg         {
     64      1.1  mrg           /* Do nothing.  */
     65      1.1  mrg           packed = 1;
     66      1.1  mrg           break;
     67      1.1  mrg         }
     68      1.1  mrg 
     69      1.1  mrg       if (ssize != stride[n])
     70      1.1  mrg         packed = 0;
     71      1.1  mrg 
     72      1.1  mrg       ssize *= extent[n];
     73      1.1  mrg     }
     74      1.1  mrg 
     75      1.1  mrg   if (packed)
     76      1.1  mrg     return source->base_addr;
     77      1.1  mrg 
     78      1.1  mrg   /* Allocate storage for the destination.  */
     79      1.1  mrg   destptr = xmallocarray (ssize, sizeof ('rtype_name`));
     80      1.1  mrg   dest = destptr;
     81      1.1  mrg   src = source->base_addr;
     82      1.1  mrg   stride0 = stride[0];
     83      1.1  mrg 
     84      1.1  mrg 
     85      1.1  mrg   while (src)
     86      1.1  mrg     {
     87      1.1  mrg       /* Copy the data.  */
     88      1.1  mrg       *(dest++) = *src;
     89      1.1  mrg       /* Advance to the next element.  */
     90      1.1  mrg       src += stride0;
     91      1.1  mrg       count[0]++;
     92      1.1  mrg       /* Advance to the next source element.  */
     93      1.1  mrg       index_type n = 0;
     94      1.1  mrg       while (count[n] == extent[n])
     95      1.1  mrg         {
     96      1.1  mrg           /* When we get to the end of a dimension, reset it and increment
     97      1.1  mrg              the next dimension.  */
     98      1.1  mrg           count[n] = 0;
     99      1.1  mrg           /* We could precalculate these products, but this is a less
    100      1.1  mrg              frequently used path so probably not worth it.  */
    101      1.1  mrg           src -= stride[n] * extent[n];
    102      1.1  mrg           n++;
    103      1.1  mrg           if (n == dim)
    104      1.1  mrg             {
    105      1.1  mrg               src = NULL;
    106      1.1  mrg               break;
    107      1.1  mrg             }
    108      1.1  mrg           else
    109      1.1  mrg             {
    110      1.1  mrg               count[n]++;
    111      1.1  mrg               src += stride[n];
    112      1.1  mrg             }
    113      1.1  mrg         }
    114      1.1  mrg     }
    115      1.1  mrg   return destptr;
    116      1.1  mrg }
    117      1.1  mrg 
    118      1.1  mrg #endif
    119      1.1  mrg '
    120