libgfortran/runtime/bounds.c

   1 /* Copyright (C) 2009-2015 Free Software Foundation, Inc.
   2    Contributed by Thomas Koenig
   3
   4 This file is part of the GNU Fortran runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 3, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 Under Section 7 of GPL version 3, you are granted additional
  17 permissions described in the GCC Runtime Library Exception, version
  18 3.1, as published by the Free Software Foundation.
  19
  20 You should have received a copy of the GNU General Public License and
  21 a copy of the GCC Runtime Library Exception along with this program;
  22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  23 <http://www.gnu.org/licenses/>.  */
  24
  25 #include "libgfortran.h"
  26 #include <assert.h>
  27
  28 /* Auxiliary functions for bounds checking, mostly to reduce library size.  */
  29
  30 /* Bounds checking for the return values of the iforeach functions (such
  31    as maxloc and minloc).  The extent of ret_array must
  32    must match the rank of array.  */
  33
  34 void
  35 bounds_iforeach_return (array_t *retarray, array_t *array, const char *name)
  36 {
  37   index_type rank;
  38   index_type ret_rank;
  39   index_type ret_extent;
  40
  41   ret_rank = GFC_DESCRIPTOR_RANK (retarray);
  42
  43   if (ret_rank != 1)
  44     runtime_error ("Incorrect rank of return array in %s intrinsic:"
  45                    "is %ld, should be 1", name, (long int) ret_rank);
  46
  47   rank = GFC_DESCRIPTOR_RANK (array);
  48   ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
  49   if (ret_extent != rank)
  50     runtime_error ("Incorrect extent in return value of"
  51                    " %s intrinsic: is %ld, should be %ld",
  52                    name, (long int) ret_extent, (long int) rank);
  53
  54 }
  55
  56 /* Check the return of functions generated from ifunction.m4.
  57    We check the array descriptor "a" against the extents precomputed
  58    from ifunction.m4, and complain about the argument a_name in the
  59    intrinsic function. */
  60
  61 void
  62 bounds_ifunction_return (array_t * a, const index_type * extent,
  63                          const char * a_name, const char * intrinsic)
  64 {
  65   int empty;
  66   int n;
  67   int rank;
  68   index_type a_size;
  69
  70   rank = GFC_DESCRIPTOR_RANK (a);
  71   a_size = size0 (a);
  72
  73   empty = 0;
  74   for (n = 0; n < rank; n++)
  75     {
  76       if (extent[n] == 0)
  77         empty = 1;
  78     }
  79   if (empty)
  80     {
  81       if (a_size != 0)
  82         runtime_error ("Incorrect size in %s of %s"
  83                        " intrinsic: should be zero-sized",
  84                        a_name, intrinsic);
  85     }
  86   else
  87     {
  88       if (a_size == 0)
  89         runtime_error ("Incorrect size of %s in %s"
  90                        " intrinsic: should not be zero-sized",
  91                        a_name, intrinsic);
  92
  93       for (n = 0; n < rank; n++)
  94         {
  95           index_type a_extent;
  96           a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
  97           if (a_extent != extent[n])
  98             runtime_error("Incorrect extent in %s of %s"
  99                           " intrinsic in dimension %ld: is %ld,"
 100                           " should be %ld", a_name, intrinsic, (long int) n + 1,
 101                           (long int) a_extent, (long int) extent[n]);
 102
 103         }
 104     }
 105 }
 106
 107 /* Check that two arrays have equal extents, or are both zero-sized.  Abort
 108    with a runtime error if this is not the case.  Complain that a has the
 109    wrong size.  */
 110
 111 void
 112 bounds_equal_extents (array_t *a, array_t *b, const char *a_name,
 113                       const char *intrinsic)
 114 {
 115   index_type a_size, b_size, n;
 116
 117   assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b));
 118
 119   a_size = size0 (a);
 120   b_size = size0 (b);
 121
 122   if (b_size == 0)
 123     {
 124       if (a_size != 0)
 125         runtime_error ("Incorrect size of %s in %s"
 126                        " intrinsic: should be zero-sized",
 127                        a_name, intrinsic);
 128     }
 129   else
 130     {
 131       if (a_size == 0)
 132         runtime_error ("Incorrect size of %s of %s"
 133                        " intrinsic: Should not be zero-sized",
 134                        a_name, intrinsic);
 135
 136       for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
 137         {
 138           index_type a_extent, b_extent;
 139
 140           a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
 141           b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
 142           if (a_extent != b_extent)
 143             runtime_error("Incorrect extent in %s of %s"
 144                           " intrinsic in dimension %ld: is %ld,"
 145                           " should be %ld", a_name, intrinsic, (long int) n + 1,
 146                           (long int) a_extent, (long int) b_extent);
 147         }
 148     }
 149 }
 150
 151 /* Check that the extents of a and b agree, except that a has a missing
 152    dimension in argument which.  Complain about a if anything is wrong.  */
 153
 154 void
 155 bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
 156                       const char *intrinsic)
 157 {
 158
 159   index_type i, n, a_size, b_size;
 160
 161   assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1);
 162
 163   a_size = size0 (a);
 164   b_size = size0 (b);
 165
 166   if (b_size == 0)
 167     {
 168       if (a_size != 0)
 169         runtime_error ("Incorrect size in %s of %s"
 170                        " intrinsic: should not be zero-sized",
 171                        a_name, intrinsic);
 172     }
 173   else
 174     {
 175       if (a_size == 0)
 176         runtime_error ("Incorrect size of %s of %s"
 177                        " intrinsic: should be zero-sized",
 178                        a_name, intrinsic);
 179
 180       i = 0;
 181       for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
 182         {
 183           index_type a_extent, b_extent;
 184
 185           if (n != which)
 186             {
 187               a_extent = GFC_DESCRIPTOR_EXTENT(a, i);
 188               b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
 189               if (a_extent != b_extent)
 190                 runtime_error("Incorrect extent in %s of %s"
 191                               " intrinsic in dimension %ld: is %ld,"
 192                               " should be %ld", a_name, intrinsic, (long int) i + 1,
 193                               (long int) a_extent, (long int) b_extent);
 194               i++;
 195             }
 196         }
 197     }
 198 }
 199
 200 /* count_0 - count all the true elements in an array.  The front
 201    end usually inlines this, we need this for bounds checking
 202    for unpack.  */
 203
 204 index_type count_0 (const gfc_array_l1 * array)
 205 {
 206   const GFC_LOGICAL_1 * restrict base;
 207   index_type rank;
 208   int kind;
 209   int continue_loop;
 210   index_type count[GFC_MAX_DIMENSIONS];
 211   index_type extent[GFC_MAX_DIMENSIONS];
 212   index_type sstride[GFC_MAX_DIMENSIONS];
 213   index_type result;
 214   index_type n;
 215
 216   rank = GFC_DESCRIPTOR_RANK (array);
 217   kind = GFC_DESCRIPTOR_SIZE (array);
 218
 219   base = array->base_addr;
 220
 221   if (kind == 1 || kind == 2 || kind == 4 || kind == 8
 222 #ifdef HAVE_GFC_LOGICAL_16
 223       || kind == 16
 224 #endif
 225     )
 226     {
 227       if (base)
 228         base = GFOR_POINTER_TO_L1 (base, kind);
 229     }
 230   else
 231     internal_error (NULL, "Funny sized logical array in count_0");
 232
 233   for (n = 0; n < rank; n++)
 234     {
 235       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 236       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 237       count[n] = 0;
 238
 239       if (extent[n] <= 0)
 240         return 0;
 241     }
 242
 243   result = 0;
 244   continue_loop = 1;
 245   while (continue_loop)
 246     {
 247       if (*base)
 248         result ++;
 249
 250       count[0]++;
 251       base += sstride[0];
 252       n = 0;
 253       while (count[n] == extent[n])
 254         {
 255           count[n] = 0;
 256           base -= sstride[n] * extent[n];
 257           n++;
 258           if (n == rank)
 259             {
 260               continue_loop = 0;
 261               break;
 262             }
 263           else
 264             {
 265               count[n]++;
 266               base += sstride[n];
 267             }
 268         }
 269     }
 270   return result;
 271 }