libgfortran/runtime/bounds.c

   1 /* Copyright (C) 2009-2017 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   /* ret_rank should always be 1, otherwise there is an internal error */
  44   GFC_ASSERT(ret_rank == 1);
  45
  46   rank = GFC_DESCRIPTOR_RANK (array);
  47   ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
  48   if (ret_extent != rank)
  49     runtime_error ("Incorrect extent in return value of"
  50                    " %s intrinsic: is %ld, should be %ld",
  51                    name, (long int) ret_extent, (long int) rank);
  52
  53 }
  54
  55 /* Check the return of functions generated from ifunction.m4.
  56    We check the array descriptor "a" against the extents precomputed
  57    from ifunction.m4, and complain about the argument a_name in the
  58    intrinsic function. */
  59
  60 void
  61 bounds_ifunction_return (array_t * a, const index_type * extent,
  62                          const char * a_name, const char * intrinsic)
  63 {
  64   int empty;
  65   int n;
  66   int rank;
  67   index_type a_size;
  68
  69   rank = GFC_DESCRIPTOR_RANK (a);
  70   a_size = size0 (a);
  71
  72   empty = 0;
  73   for (n = 0; n < rank; n++)
  74     {
  75       if (extent[n] == 0)
  76         empty = 1;
  77     }
  78   if (empty)
  79     {
  80       if (a_size != 0)
  81         runtime_error ("Incorrect size in %s of %s"
  82                        " intrinsic: should be zero-sized",
  83                        a_name, intrinsic);
  84     }
  85   else
  86     {
  87       if (a_size == 0)
  88         runtime_error ("Incorrect size of %s in %s"
  89                        " intrinsic: should not be zero-sized",
  90                        a_name, intrinsic);
  91
  92       for (n = 0; n < rank; n++)
  93         {
  94           index_type a_extent;
  95           a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
  96           if (a_extent != extent[n])
  97             runtime_error("Incorrect extent in %s of %s"
  98                           " intrinsic in dimension %ld: is %ld,"
  99                           " should be %ld", a_name, intrinsic, (long int) n + 1,
 100                           (long int) a_extent, (long int) extent[n]);
 101
 102         }
 103     }
 104 }
 105
 106 /* Check that two arrays have equal extents, or are both zero-sized.  Abort
 107    with a runtime error if this is not the case.  Complain that a has the
 108    wrong size.  */
 109
 110 void
 111 bounds_equal_extents (array_t *a, array_t *b, const char *a_name,
 112                       const char *intrinsic)
 113 {
 114   index_type a_size, b_size, n;
 115
 116   assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b));
 117
 118   a_size = size0 (a);
 119   b_size = size0 (b);
 120
 121   if (b_size == 0)
 122     {
 123       if (a_size != 0)
 124         runtime_error ("Incorrect size of %s in %s"
 125                        " intrinsic: should be zero-sized",
 126                        a_name, intrinsic);
 127     }
 128   else
 129     {
 130       if (a_size == 0)
 131         runtime_error ("Incorrect size of %s of %s"
 132                        " intrinsic: Should not be zero-sized",
 133                        a_name, intrinsic);
 134
 135       for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
 136         {
 137           index_type a_extent, b_extent;
 138
 139           a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
 140           b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
 141           if (a_extent != b_extent)
 142             runtime_error("Incorrect extent in %s of %s"
 143                           " intrinsic in dimension %ld: is %ld,"
 144                           " should be %ld", a_name, intrinsic, (long int) n + 1,
 145                           (long int) a_extent, (long int) b_extent);
 146         }
 147     }
 148 }
 149
 150 /* Check that the extents of a and b agree, except that a has a missing
 151    dimension in argument which.  Complain about a if anything is wrong.  */
 152
 153 void
 154 bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
 155                       const char *intrinsic)
 156 {
 157
 158   index_type i, n, a_size, b_size;
 159
 160   assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1);
 161
 162   a_size = size0 (a);
 163   b_size = size0 (b);
 164
 165   if (b_size == 0)
 166     {
 167       if (a_size != 0)
 168         runtime_error ("Incorrect size in %s of %s"
 169                        " intrinsic: should not be zero-sized",
 170                        a_name, intrinsic);
 171     }
 172   else
 173     {
 174       if (a_size == 0)
 175         runtime_error ("Incorrect size of %s of %s"
 176                        " intrinsic: should be zero-sized",
 177                        a_name, intrinsic);
 178
 179       i = 0;
 180       for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
 181         {
 182           index_type a_extent, b_extent;
 183
 184           if (n != which)
 185             {
 186               a_extent = GFC_DESCRIPTOR_EXTENT(a, i);
 187               b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
 188               if (a_extent != b_extent)
 189                 runtime_error("Incorrect extent in %s of %s"
 190                               " intrinsic in dimension %ld: is %ld,"
 191                               " should be %ld", a_name, intrinsic, (long int) i + 1,
 192                               (long int) a_extent, (long int) b_extent);
 193               i++;
 194             }
 195         }
 196     }
 197 }
 198
 199 /* count_0 - count all the true elements in an array.  The front
 200    end usually inlines this, we need this for bounds checking
 201    for unpack.  */
 202
 203 index_type count_0 (const gfc_array_l1 * array)
 204 {
 205   const GFC_LOGICAL_1 * restrict base;
 206   index_type rank;
 207   int kind;
 208   int continue_loop;
 209   index_type count[GFC_MAX_DIMENSIONS];
 210   index_type extent[GFC_MAX_DIMENSIONS];
 211   index_type sstride[GFC_MAX_DIMENSIONS];
 212   index_type result;
 213   index_type n;
 214
 215   rank = GFC_DESCRIPTOR_RANK (array);
 216   kind = GFC_DESCRIPTOR_SIZE (array);
 217
 218   base = array->base_addr;
 219
 220   if (kind == 1 || kind == 2 || kind == 4 || kind == 8
 221 #ifdef HAVE_GFC_LOGICAL_16
 222       || kind == 16
 223 #endif
 224     )
 225     {
 226       if (base)
 227         base = GFOR_POINTER_TO_L1 (base, kind);
 228     }
 229   else
 230     internal_error (NULL, "Funny sized logical array in count_0");
 231
 232   for (n = 0; n < rank; n++)
 233     {
 234       sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
 235       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 236       count[n] = 0;
 237
 238       if (extent[n] <= 0)
 239         return 0;
 240     }
 241
 242   result = 0;
 243   continue_loop = 1;
 244   while (continue_loop)
 245     {
 246       if (*base)
 247         result ++;
 248
 249       count[0]++;
 250       base += sstride[0];
 251       n = 0;
 252       while (count[n] == extent[n])
 253         {
 254           count[n] = 0;
 255           base -= sstride[n] * extent[n];
 256           n++;
 257           if (n == rank)
 258             {
 259               continue_loop = 0;
 260               break;
 261             }
 262           else
 263             {
 264               count[n]++;
 265               base += sstride[n];
 266             }
 267         }
 268     }
 269   return result;
 270 }