This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, libfortran] Bounds checking for (c|eo)shift, bounds checking library functions
- From: Thomas Koenig <tkoenig at netcologne dot de>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Tue, 14 Jul 2009 20:27:08 +0200
- Subject: [patch, libfortran] Bounds checking for (c|eo)shift, bounds checking library functions
Hello world,
this patch implements bounds checking for the cshift and eoshift library
functions. It also moves common code for bounds checking into library
functions, and adds some extra checks for zero-sized arrays to make sure
we don't reject valid code like
a(1:0,2:3) = eoshift(b(1:2,1:0),1)
I decided to create a new file in the runtime directory for that.
Regression-tested on i686-pc-linux-gnu. OK for trunk?
2009-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34670
PR libfortran/36874
* Makefile.am: Add bounds.c
* libgfortran.h (bounds_equal_extents): Add prototype.
(bounds_iforeach_return): Likewise.
(bounds_ifunction_return): Likewise.
(bounds_reduced_extents): Likewise.
* runtime/bounds.c: New file.
(bounds_iforeach_return): New function.
(bounds_ifunction_return): Likewise.
(bounds_equal_extents): Add prototype.
(bounds_reduced_extents): Likewise.
* intrinsics/cshift0.c (cshift0): Use new functions
for bounds checking.
* intrinsics/eoshift0.c (eoshift0): Likewise.
* intrinsics/eoshift2.c (eoshift2): Likewise.
* m4/iforeach.m4: Likewise.
* m4/eoshift1.m4: Likewise.
* m4/eoshift3.m4: Likewise.
* m4/cshift1.m4: Likewise.
* m4/ifunction.m4: Likewise.
* Makefile.in: Regenerated.
* generated/cshift1_16.c: Regenerated.
* generated/cshift1_4.c: Regenerated.
* generated/cshift1_8.c: Regenerated.
* generated/eoshift1_16.c: Regenerated.
* generated/eoshift1_4.c: Regenerated.
* generated/eoshift1_8.c: Regenerated.
* generated/eoshift3_16.c: Regenerated.
* generated/eoshift3_4.c: Regenerated.
* generated/eoshift3_8.c: Regenerated.
* generated/maxloc0_16_i1.c: Regenerated.
* generated/maxloc0_16_i16.c: Regenerated.
* generated/maxloc0_16_i2.c: Regenerated.
* generated/maxloc0_16_i4.c: Regenerated.
* generated/maxloc0_16_i8.c: Regenerated.
* generated/maxloc0_16_r10.c: Regenerated.
* generated/maxloc0_16_r16.c: Regenerated.
* generated/maxloc0_16_r4.c: Regenerated.
* generated/maxloc0_16_r8.c: Regenerated.
* generated/maxloc0_4_i1.c: Regenerated.
* generated/maxloc0_4_i16.c: Regenerated.
* generated/maxloc0_4_i2.c: Regenerated.
* generated/maxloc0_4_i4.c: Regenerated.
* generated/maxloc0_4_i8.c: Regenerated.
* generated/maxloc0_4_r10.c: Regenerated.
* generated/maxloc0_4_r16.c: Regenerated.
* generated/maxloc0_4_r4.c: Regenerated.
* generated/maxloc0_4_r8.c: Regenerated.
* generated/maxloc0_8_i1.c: Regenerated.
* generated/maxloc0_8_i16.c: Regenerated.
* generated/maxloc0_8_i2.c: Regenerated.
* generated/maxloc0_8_i4.c: Regenerated.
* generated/maxloc0_8_i8.c: Regenerated.
* generated/maxloc0_8_r10.c: Regenerated.
* generated/maxloc0_8_r16.c: Regenerated.
* generated/maxloc0_8_r4.c: Regenerated.
* generated/maxloc0_8_r8.c: Regenerated.
* generated/maxloc1_16_i1.c: Regenerated.
* generated/maxloc1_16_i16.c: Regenerated.
* generated/maxloc1_16_i2.c: Regenerated.
* generated/maxloc1_16_i4.c: Regenerated.
* generated/maxloc1_16_i8.c: Regenerated.
* generated/maxloc1_16_r10.c: Regenerated.
* generated/maxloc1_16_r16.c: Regenerated.
* generated/maxloc1_16_r4.c: Regenerated.
* generated/maxloc1_16_r8.c: Regenerated.
* generated/maxloc1_4_i1.c: Regenerated.
* generated/maxloc1_4_i16.c: Regenerated.
* generated/maxloc1_4_i2.c: Regenerated.
* generated/maxloc1_4_i4.c: Regenerated.
* generated/maxloc1_4_i8.c: Regenerated.
* generated/maxloc1_4_r10.c: Regenerated.
* generated/maxloc1_4_r16.c: Regenerated.
* generated/maxloc1_4_r4.c: Regenerated.
* generated/maxloc1_4_r8.c: Regenerated.
* generated/maxloc1_8_i1.c: Regenerated.
* generated/maxloc1_8_i16.c: Regenerated.
* generated/maxloc1_8_i2.c: Regenerated.
* generated/maxloc1_8_i4.c: Regenerated.
* generated/maxloc1_8_i8.c: Regenerated.
* generated/maxloc1_8_r10.c: Regenerated.
* generated/maxloc1_8_r16.c: Regenerated.
* generated/maxloc1_8_r4.c: Regenerated.
* generated/maxloc1_8_r8.c: Regenerated.
* generated/maxval_i1.c: Regenerated.
* generated/maxval_i16.c: Regenerated.
* generated/maxval_i2.c: Regenerated.
* generated/maxval_i4.c: Regenerated.
* generated/maxval_i8.c: Regenerated.
* generated/maxval_r10.c: Regenerated.
* generated/maxval_r16.c: Regenerated.
* generated/maxval_r4.c: Regenerated.
* generated/maxval_r8.c: Regenerated.
* generated/minloc0_16_i1.c: Regenerated.
* generated/minloc0_16_i16.c: Regenerated.
* generated/minloc0_16_i2.c: Regenerated.
* generated/minloc0_16_i4.c: Regenerated.
* generated/minloc0_16_i8.c: Regenerated.
* generated/minloc0_16_r10.c: Regenerated.
* generated/minloc0_16_r16.c: Regenerated.
* generated/minloc0_16_r4.c: Regenerated.
* generated/minloc0_16_r8.c: Regenerated.
* generated/minloc0_4_i1.c: Regenerated.
* generated/minloc0_4_i16.c: Regenerated.
* generated/minloc0_4_i2.c: Regenerated.
* generated/minloc0_4_i4.c: Regenerated.
* generated/minloc0_4_i8.c: Regenerated.
* generated/minloc0_4_r10.c: Regenerated.
* generated/minloc0_4_r16.c: Regenerated.
* generated/minloc0_4_r4.c: Regenerated.
* generated/minloc0_4_r8.c: Regenerated.
* generated/minloc0_8_i1.c: Regenerated.
* generated/minloc0_8_i16.c: Regenerated.
* generated/minloc0_8_i2.c: Regenerated.
* generated/minloc0_8_i4.c: Regenerated.
* generated/minloc0_8_i8.c: Regenerated.
* generated/minloc0_8_r10.c: Regenerated.
* generated/minloc0_8_r16.c: Regenerated.
* generated/minloc0_8_r4.c: Regenerated.
* generated/minloc0_8_r8.c: Regenerated.
* generated/minloc1_16_i1.c: Regenerated.
* generated/minloc1_16_i16.c: Regenerated.
* generated/minloc1_16_i2.c: Regenerated.
* generated/minloc1_16_i4.c: Regenerated.
* generated/minloc1_16_i8.c: Regenerated.
* generated/minloc1_16_r10.c: Regenerated.
* generated/minloc1_16_r16.c: Regenerated.
* generated/minloc1_16_r4.c: Regenerated.
* generated/minloc1_16_r8.c: Regenerated.
* generated/minloc1_4_i1.c: Regenerated.
* generated/minloc1_4_i16.c: Regenerated.
* generated/minloc1_4_i2.c: Regenerated.
* generated/minloc1_4_i4.c: Regenerated.
* generated/minloc1_4_i8.c: Regenerated.
* generated/minloc1_4_r10.c: Regenerated.
* generated/minloc1_4_r16.c: Regenerated.
* generated/minloc1_4_r4.c: Regenerated.
* generated/minloc1_4_r8.c: Regenerated.
* generated/minloc1_8_i1.c: Regenerated.
* generated/minloc1_8_i16.c: Regenerated.
* generated/minloc1_8_i2.c: Regenerated.
* generated/minloc1_8_i4.c: Regenerated.
* generated/minloc1_8_i8.c: Regenerated.
* generated/minloc1_8_r10.c: Regenerated.
* generated/minloc1_8_r16.c: Regenerated.
* generated/minloc1_8_r4.c: Regenerated.
* generated/minloc1_8_r8.c: Regenerated.
* generated/minval_i1.c: Regenerated.
* generated/minval_i16.c: Regenerated.
* generated/minval_i2.c: Regenerated.
* generated/minval_i4.c: Regenerated.
* generated/minval_i8.c: Regenerated.
* generated/minval_r10.c: Regenerated.
* generated/minval_r16.c: Regenerated.
* generated/minval_r4.c: Regenerated.
* generated/minval_r8.c: Regenerated.
* generated/product_c10.c: Regenerated.
* generated/product_c16.c: Regenerated.
* generated/product_c4.c: Regenerated.
* generated/product_c8.c: Regenerated.
* generated/product_i1.c: Regenerated.
* generated/product_i16.c: Regenerated.
* generated/product_i2.c: Regenerated.
* generated/product_i4.c: Regenerated.
* generated/product_i8.c: Regenerated.
* generated/product_r10.c: Regenerated.
* generated/product_r16.c: Regenerated.
* generated/product_r4.c: Regenerated.
* generated/product_r8.c: Regenerated.
* generated/sum_c10.c: Regenerated.
* generated/sum_c16.c: Regenerated.
* generated/sum_c4.c: Regenerated.
* generated/sum_c8.c: Regenerated.
* generated/sum_i1.c: Regenerated.
* generated/sum_i16.c: Regenerated.
* generated/sum_i2.c: Regenerated.
* generated/sum_i4.c: Regenerated.
* generated/sum_i8.c: Regenerated.
* generated/sum_r10.c: Regenerated.
* generated/sum_r16.c: Regenerated.
* generated/sum_r4.c: Regenerated.
* generated/sum_r8.c: Regenerated.
2009-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/34670
PR libfortran/36874
* gfortran.dg/cshift_bounds_1.f90: New test.
* gfortran.dg/cshift_bounds_2.f90: New test.
* gfortran.dg/cshift_bounds_3.f90: New test.
* gfortran.dg/cshift_bounds_4.f90: New test.
* gfortran.dg/eoshift_bounds_1.f90: New test.
Index: Makefile.am
===================================================================
--- Makefile.am (revision 149154)
+++ Makefile.am (working copy)
@@ -122,6 +122,7 @@ runtime/in_unpack_generic.c
gfor_src= \
runtime/backtrace.c \
+runtime/bounds.c \
runtime/compile_options.c \
runtime/convert_char.c \
runtime/environ.c \
Index: libgfortran.h
===================================================================
--- libgfortran.h (revision 149154)
+++ libgfortran.h (working copy)
@@ -1242,6 +1242,23 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DI
extern index_type size0 (const array_t * array);
iexport_proto(size0);
+/* bounds.c */
+
+extern void bounds_equal_extents (array_t *, array_t *, const char *,
+ const char *);
+internal_proto(bounds_equal_extents);
+
+void bounds_reduced_extents (array_t *, array_t *, int, const char *,
+ const char *intrinsic);
+internal_proto(bounds_reduced_extents);
+
+extern void bounds_iforeach_return (array_t *, array_t *, const char *);
+internal_proto(bounds_iforeach_return);
+
+extern void bounds_ifunction_return (array_t *, const index_type *,
+ const char *, const char *);
+internal_proto(bounds_ifunction_return);
+
/* Internal auxiliary functions for cshift */
void cshift0_i1 (gfc_array_i1 *, const gfc_array_i1 *, ssize_t, int);
Index: runtime/bounds.c
===================================================================
--- runtime/bounds.c (revision 0)
+++ runtime/bounds.c (revision 0)
@@ -0,0 +1,194 @@
+/* Copyright (C) 2009
+ Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <assert.h>
+
+/* Auxiliary functions for bounds checking, mostly to reduce library size. */
+
+/* Bounds checking for the return values of the iforeach functions. */
+
+void
+bounds_iforeach_return (array_t *retarray, array_t *array, const char *name)
+{
+ index_type rank;
+ index_type ret_rank;
+ index_type ret_extent;
+
+ ret_rank = GFC_DESCRIPTOR_RANK (retarray);
+
+ if (ret_rank != 1)
+ runtime_error ("rank of return array in %s intrinsic"
+ " should be 1, is %ld", name, (long int) ret_rank);
+
+ rank = GFC_DESCRIPTOR_RANK (array);
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
+ if (ret_extent != rank)
+ runtime_error ("Incorrect extent in return value of"
+ " %s intrnisic: is %ld, should be %ld",
+ name, (long int) ret_extent, (long int) rank);
+
+}
+
+/* Check the return of functions generated from ifunction.m4. */
+
+void
+bounds_ifunction_return (array_t * a, const index_type * extent,
+ const char * a_name, const char * intrinsic)
+{
+ int empty;
+ int n;
+ int rank;
+ index_type a_size;
+
+ rank = GFC_DESCRIPTOR_RANK (a);
+ a_size = size0 (a);
+
+ empty = 0;
+ for (n = 0; n < rank; n++)
+ {
+ if (extent[n] == 0)
+ empty = 1;
+ }
+ if (empty)
+ {
+ if (a_size != 0)
+ runtime_error ("Incorrect size in %s of %s"
+ " intrinsic: should be zero-sized",
+ a_name, intrinsic);
+ }
+ else
+ {
+ if (a_size == 0)
+ runtime_error ("Incorrect size of %s in %s"
+ " intrinsic: should not be zero-sized",
+ a_name, intrinsic);
+
+ for (n = 0; n < rank; n++)
+ {
+ index_type a_extent;
+ a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
+ if (a_extent != extent[n])
+ runtime_error("Incorrect extent in %s of %s"
+ " intrinsic in dimension %ld: is %ld,"
+ " should be %ld", a_name, intrinsic, (long int) n + 1,
+ (long int) a_extent, (long int) extent[n]);
+
+ }
+ }
+}
+
+/* Check that two arrays have equal extents, or are both zero-sized. Abort
+ with a runtime error if this is not the case. Complain that a has the
+ wrong size. */
+
+void
+bounds_equal_extents (array_t *a, array_t *b, const char *a_name,
+ const char *intrinsic)
+{
+ index_type a_size, b_size, n;
+
+ assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b));
+
+ a_size = size0 (a);
+ b_size = size0 (b);
+
+ if (b_size == 0)
+ {
+ if (a_size != 0)
+ runtime_error ("Incorrect size of %s in %s"
+ " intrinsic: should be zero-sized",
+ a_name, intrinsic);
+ }
+ else
+ {
+ if (a_size == 0)
+ runtime_error ("Incorrect size of %s of %s"
+ " intrinsic: Should not be zero-sized",
+ a_name, intrinsic);
+
+ for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
+ {
+ index_type a_extent, b_extent;
+
+ a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
+ b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
+ if (a_extent != b_extent)
+ runtime_error("Incorrect extent in %s of %s"
+ " intrinsic in dimension %ld: is %ld,"
+ " should be %ld", a_name, intrinsic, (long int) n + 1,
+ (long int) a_extent, (long int) b_extent);
+ }
+ }
+}
+
+/* Check that the extents of a and b agree, except that a has a missing
+ dimension in argument which. Complain about a if anything is wrong. */
+
+void
+bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
+ const char *intrinsic)
+{
+
+ index_type i, n, a_size, b_size;
+
+ assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1);
+
+ a_size = size0 (a);
+ b_size = size0 (b);
+
+ if (b_size == 0)
+ {
+ if (a_size != 0)
+ runtime_error ("Incorrect size in %s of %s"
+ " intrinsic: should be zero-sized",
+ a_name, intrinsic);
+ }
+ else
+ {
+ if (a_size == 0)
+ runtime_error ("Incorrect size of %s of %s"
+ " intrinsic: Should not be zero-sized",
+ a_name, intrinsic);
+
+ i = 0;
+ for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
+ {
+ index_type a_extent, b_extent;
+
+ if (n != which)
+ {
+ a_extent = GFC_DESCRIPTOR_EXTENT(a, i);
+ b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
+ if (a_extent != b_extent)
+ runtime_error("Incorrect extent in %s of %s"
+ " intrinsic in dimension %ld: is %ld,"
+ " should be %ld", a_name, intrinsic, (long int) i + 1,
+ (long int) a_extent, (long int) b_extent);
+ i++;
+ }
+ }
+ }
+}
Index: intrinsics/cshift0.c
===================================================================
--- intrinsics/cshift0.c (revision 149154)
+++ intrinsics/cshift0.c (working copy)
@@ -87,14 +87,17 @@ cshift0 (gfc_array_char * ret, const gfc
if (arraysize > 0)
ret->data = internal_malloc_size (size * arraysize);
else
- {
- ret->data = internal_malloc_size (1);
- return;
- }
+ ret->data = internal_malloc_size (1);
}
-
+ else if (unlikely (compile_options.bounds_check))
+ {
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "CSHIFT");
+ }
+
if (arraysize == 0)
return;
+
type_size = GFC_DTYPE_TYPE_SIZE (array);
switch(type_size)
Index: intrinsics/eoshift0.c
===================================================================
--- intrinsics/eoshift0.c (revision 149154)
+++ intrinsics/eoshift0.c (working copy)
@@ -54,6 +54,7 @@ eoshift0 (gfc_array_char * ret, const gf
index_type dim;
index_type len;
index_type n;
+ index_type arraysize;
/* The compiler cannot figure out that these are set, initialize
them to avoid warnings. */
@@ -61,6 +62,8 @@ eoshift0 (gfc_array_char * ret, const gf
soffset = 0;
roffset = 0;
+ arraysize = size0 ((array_t *) array);
+
if (ret->data == NULL)
{
int i;
@@ -83,13 +86,22 @@ eoshift0 (gfc_array_char * ret, const gf
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
+
+ if (arraysize > 0)
+ ret->data = internal_malloc_size (size * arraysize);
+ else
+ ret->data = internal_malloc_size (1);
+
}
- else
+ else if (unlikely (compile_options.bounds_check))
{
- if (size0 ((array_t *) ret) == 0)
- return;
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "EOSHIFT");
}
+ if (arraysize == 0)
+ return;
+
which = which - 1;
extent[0] = 1;
Index: intrinsics/eoshift2.c
===================================================================
--- intrinsics/eoshift2.c (revision 149154)
+++ intrinsics/eoshift2.c (working copy)
@@ -94,13 +94,13 @@ eoshift2 (gfc_array_char *ret, const gfc
}
}
- else
+ else if (unlikely (compile_options.bounds_check))
{
- if (size0 ((array_t *) ret) == 0)
- return;
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "EOSHIFT");
}
- if (arraysize == 0 && filler == NULL)
+ if (arraysize == 0)
return;
which = which - 1;
Index: m4/iforeach.m4
===================================================================
--- m4/iforeach.m4 (revision 149154)
+++ m4/iforeach.m4 (working copy)
@@ -35,21 +35,8 @@ name`'rtype_qual`_'atype_code (rtype * c
else
{
if (unlikely (compile_options.bounds_check))
- {
- int ret_rank;
- index_type ret_extent;
-
- ret_rank = GFC_DESCRIPTOR_RANK (retarray);
- if (ret_rank != 1)
- runtime_error ("rank of return array in u_name intrinsic"
- " should be 1, is %ld", (long int) ret_rank);
-
- ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
- if (ret_extent != rank)
- runtime_error ("Incorrect extent in return value of"
- " u_name intrnisic: is %ld, should be %ld",
- (long int) ret_extent, (long int) rank);
- }
+ bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+ "u_name");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
@@ -150,38 +137,11 @@ void
{
if (unlikely (compile_options.bounds_check))
{
- int ret_rank, mask_rank;
- index_type ret_extent;
- int n;
- index_type array_extent, mask_extent;
-
- ret_rank = GFC_DESCRIPTOR_RANK (retarray);
- if (ret_rank != 1)
- runtime_error ("rank of return array in u_name intrinsic"
- " should be 1, is %ld", (long int) ret_rank);
-
- ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
- if (ret_extent != rank)
- runtime_error ("Incorrect extent in return value of"
- " u_name intrnisic: is %ld, should be %ld",
- (long int) ret_extent, (long int) rank);
-
- mask_rank = GFC_DESCRIPTOR_RANK (mask);
- if (rank != mask_rank)
- runtime_error ("rank of MASK argument in u_name intrnisic"
- "should be %ld, is %ld", (long int) rank,
- (long int) mask_rank);
-
- for (n=0; n<rank; n++)
- {
- array_extent = GFC_DESCRIPTOR_EXTENT(array,n);
- mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
- if (array_extent != mask_extent)
- runtime_error ("Incorrect extent in MASK argument of"
- " u_name intrinsic in dimension %ld:"
- " is %ld, should be %ld", (long int) n + 1,
- (long int) mask_extent, (long int) array_extent);
- }
+
+ bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+ "u_name");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "u_name");
}
}
@@ -303,22 +263,10 @@ void
retarray->offset = 0;
retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
}
- else
+ else if (unlikely (compile_options.bounds_check))
{
- if (unlikely (compile_options.bounds_check))
- {
- int ret_rank;
- index_type ret_extent;
-
- ret_rank = GFC_DESCRIPTOR_RANK (retarray);
- if (ret_rank != 1)
- runtime_error ("rank of return array in u_name intrinsic"
- " should be 1, is %ld", (long int) ret_rank);
-
- ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
- if (ret_extent != rank)
- runtime_error ("dimension of return array incorrect");
- }
+ bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+ "u_name");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
Index: m4/eoshift1.m4
===================================================================
--- m4/eoshift1.m4 (revision 149154)
+++ m4/eoshift1.m4 (working copy)
@@ -63,6 +63,7 @@ eoshift1 (gfc_array_char * const restric
index_type len;
index_type n;
index_type size;
+ index_type arraysize;
int which;
'atype_name` sh;
'atype_name` delta;
@@ -83,11 +84,12 @@ eoshift1 (gfc_array_char * const restric
extent[0] = 1;
count[0] = 0;
+ arraysize = size0 ((array_t *) array);
if (ret->data == NULL)
{
int i;
- ret->data = internal_malloc_size (size * size0 ((array_t *)array));
+ ret->data = internal_malloc_size (size * arraysize);
ret->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
@@ -105,13 +107,21 @@ eoshift1 (gfc_array_char * const restric
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
+ if (arraysize > 0)
+ ret->data = internal_malloc_size (size * arraysize);
+ else
+ ret->data = internal_malloc_size (1);
+
}
- else
+ else if (unlikely (compile_options.bounds_check))
{
- if (size0 ((array_t *) ret) == 0)
- return;
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "EOSHIFT");
}
+ if (arraysize == 0)
+ return;
+
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
Index: m4/eoshift3.m4
===================================================================
--- m4/eoshift3.m4 (revision 149154)
+++ m4/eoshift3.m4 (working copy)
@@ -67,6 +67,7 @@ eoshift3 (gfc_array_char * const restric
index_type len;
index_type n;
index_type size;
+ index_type arraysize;
int which;
'atype_name` sh;
'atype_name` delta;
@@ -77,6 +78,7 @@ eoshift3 (gfc_array_char * const restric
soffset = 0;
roffset = 0;
+ arraysize = size0 ((array_t *) array);
size = GFC_DESCRIPTOR_SIZE(array);
if (pwhich)
@@ -88,7 +90,7 @@ eoshift3 (gfc_array_char * const restric
{
int i;
- ret->data = internal_malloc_size (size * size0 ((array_t *)array));
+ ret->data = internal_malloc_size (size * arraysize);
ret->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
@@ -106,13 +108,26 @@ eoshift3 (gfc_array_char * const restric
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
+ if (arraysize > 0)
+ ret->data = internal_malloc_size (size * arraysize);
+ else
+ ret->data = internal_malloc_size (1);
+
}
- else
+ else if (unlikely (compile_options.bounds_check))
+ {
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "EOSHIFT");
+ }
+
+ if (unlikely (compile_options.bounds_check))
{
- if (size0 ((array_t *) ret) == 0)
- return;
+ bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
+ "SHIFT", "EOSHIFT");
}
+ if (arraysize == 0)
+ return;
extent[0] = 1;
count[0] = 0;
Index: m4/cshift1.m4
===================================================================
--- m4/cshift1.m4 (revision 149154)
+++ m4/cshift1.m4 (working copy)
@@ -99,6 +99,17 @@ cshift1 (gfc_array_char * const restrict
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
}
+ else if (unlikely (compile_options.bounds_check))
+ {
+ bounds_equal_extents ((array_t *) ret, (array_t *) array,
+ "return value", "CSHIFT");
+ }
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
+ "SHIFT", "CSHIFT");
+ }
if (arraysize == 0)
return;
Index: m4/ifunction.m4
===================================================================
--- m4/ifunction.m4 (revision 149154)
+++ m4/ifunction.m4 (working copy)
@@ -107,19 +107,8 @@ name`'rtype_qual`_'atype_code (rtype * c
(long int) rank);
if (unlikely (compile_options.bounds_check))
- {
- for (n=0; n < rank; n++)
- {
- index_type ret_extent;
-
- ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
- if (extent[n] != ret_extent)
- runtime_error ("Incorrect extent in return value of"
- " u_name intrinsic in dimension %ld:"
- " is %ld, should be %ld", (long int) n + 1,
- (long int) ret_extent, (long int) extent[n]);
- }
- }
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "u_name");
}
for (n = 0; n < rank; n++)
@@ -294,29 +283,10 @@ void
if (unlikely (compile_options.bounds_check))
{
- for (n=0; n < rank; n++)
- {
- index_type ret_extent;
-
- ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
- if (extent[n] != ret_extent)
- runtime_error ("Incorrect extent in return value of"
- " u_name intrinsic in dimension %ld:"
- " is %ld, should be %ld", (long int) n + 1,
- (long int) ret_extent, (long int) extent[n]);
- }
- for (n=0; n<= rank; n++)
- {
- index_type mask_extent, array_extent;
-
- array_extent = GFC_DESCRIPTOR_EXTENT(array,n);
- mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
- if (array_extent != mask_extent)
- runtime_error ("Incorrect extent in MASK argument of"
- " u_name intrinsic in dimension %ld:"
- " is %ld, should be %ld", (long int) n + 1,
- (long int) mask_extent, (long int) array_extent);
- }
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "u_name");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "u_name");
}
}
! { dg-do run }
! { dg-options "-fbounds-check" }
! Check that empty arrays are handled correctly in
! cshift and eoshift
program main
character(len=50) :: line
character(len=3), dimension(2,2) :: a, b
integer :: n1, n2
line = '-1-2'
read (line,'(2I2)') n1, n2
call foo(a, b, n1, n2)
a = 'abc'
write (line,'(4A)') eoshift(a, 3)
write (line,'(4A)') cshift(a, 3)
write (line,'(4A)') cshift(a(:,1:n1), 3)
write (line,'(4A)') eoshift(a(1:n2,:), 3)
end program main
subroutine foo(a, b, n1, n2)
character(len=3), dimension(2, n1) :: a
character(len=3), dimension(n2, 2) :: b
a = cshift(b,1)
a = eoshift(b,1)
end subroutine foo
! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
program main
integer, dimension(:,:), allocatable :: a, b
allocate (a(2,2))
allocate (b(2,3))
a = 1
b = cshift(a,1)
end program main
! { dg-output "Fortran runtime error: Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" }
program main
real, dimension(1,0) :: a, b, c
integer :: sp(3), i
a = 4.0
sp = 1
i = 1
b = cshift (a,sp(1:i)) ! Invalid
end program main
! { dg-output "Fortran runtime error: Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" }
! { dg-do run }
! { dg-shouldfail "Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" }
! { dg-options "-fbounds-check" }
program main
integer, dimension(:,:), allocatable :: a, b
integer, dimension(:), allocatable :: sh
allocate (a(2,2))
allocate (b(2,2))
allocate (sh(3))
a = 1
b = cshift(a,sh)
end program main
! { dg-output "Fortran runtime error: Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" }
! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Incorrect size in SHIFT argument of EOSHIFT intrinsic: should not be zero-sized" }
program main
real, dimension(1,0) :: a, b, c
integer :: sp(3), i
a = 4.0
sp = 1
i = 1
b = eoshift (a,sp(1:i)) ! Invalid
end program main
! { dg-output "Fortran runtime error: Incorrect size in SHIFT argument of EOSHIFT intrinsic: should not be zero-sized" }