libgfortran/runtime/bounds.c

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