libgfortran/runtime/bounds.c

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