From: Thomas Koenig Date: Sun, 29 Sep 2024 14:52:51 +0000 (+0200) Subject: Implement MAXVAL and MINVAL for UNSIGNED. X-Git-Tag: basepoints/gcc-16~5557 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=9dd9a06940a37e82d13ccd2be0c4ef68bca29750;p=thirdparty%2Fgcc.git Implement MAXVAL and MINVAL for UNSIGNED. gcc/fortran/ChangeLog: * check.cc (int_or_real_or_char_or_unsigned_check_f2003): New function. (gfc_check_minval_maxval): Use it. * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxval): Handle initial values for UNSIGNED. * gfortran.texi: Document MINVAL and MAXVAL for unsigned. libgfortran/ChangeLog: * Makefile.am: Add minval and maxval files. * Makefile.in: Regenerated. * gfortran.map: Add new functions. * generated/maxval_m1.c: New file. * generated/maxval_m16.c: New file. * generated/maxval_m2.c: New file. * generated/maxval_m4.c: New file. * generated/maxval_m8.c: New file. * generated/minval_m1.c: New file. * generated/minval_m16.c: New file. * generated/minval_m2.c: New file. * generated/minval_m4.c: New file. * generated/minval_m8.c: New file. gcc/testsuite/ChangeLog: * gfortran.dg/unsigned_34.f90: New test. --- diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index dd79a49a0c9..9c0b72fa010 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -637,6 +637,39 @@ int_or_real_or_char_check_f2003 (gfc_expr *e, int n) return true; } +/* Check that an expression is integer or real or unsigned; allow character for + F2003 or later. */ + +static bool +int_or_real_or_char_or_unsigned_check_f2003 (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL + && e->ts.type != BT_UNSIGNED) + { + if (e->ts.type == BT_CHARACTER) + return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for " + "%qs argument of %qs intrinsic at %L", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + else + { + if (gfc_option.allow_std & GFC_STD_F2003) + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or REAL or CHARACTER or UNSIGNED", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + else + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or REAL or UNSIGNED", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + } + return false; + } + + return true; +} + /* Check that an expression is an intrinsic type. */ static bool intrinsic_type_check (gfc_expr *e, int n) @@ -4389,8 +4422,15 @@ check_reduction (gfc_actual_arglist *ap) bool gfc_check_minval_maxval (gfc_actual_arglist *ap) { - if (!int_or_real_or_char_check_f2003 (ap->expr, 0) - || !array_check (ap->expr, 0)) + if (flag_unsigned) + { + if (!int_or_real_or_char_or_unsigned_check_f2003 (ap->expr, 0)) + return false; + } + else if (!int_or_real_or_char_check_f2003 (ap->expr, 0)) + return false; + + if (!array_check (ap->expr, 0)) return false; return check_reduction (ap); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 7aa16428867..db8c44fbe96 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -2792,7 +2792,8 @@ As of now, the following intrinsics take unsigned arguments: @item @code{IANY}, @code{IALL} and @code{IPARITY} @item @code{RANDOM_NUMBER} @item @code{CSHIFT} and @code{EOSHIFT} -@item @code{FINDLOC}. +@item @code{FINDLOC} +@item @code{MAXVAL} and @code{MINVAL}. @end itemize This list will grow in the near future. @c --------------------------------------------------------------------- diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 5505a212bd0..e065e31aaf8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -6443,6 +6443,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); break; + case BT_UNSIGNED: + /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */ + if (op == GT_EXPR) + tmp = build_int_cst (type, 0); + else + tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge, + expr->ts.kind); + break; + default: gcc_unreachable (); } @@ -6450,8 +6459,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) /* We start with the most negative possible value for MAXVAL, and the most positive possible value for MINVAL. The most negative possible value is -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive - possible value is HUGE in both cases. */ - if (op == GT_EXPR) + possible value is HUGE in both cases. BT_UNSIGNED has already been dealt + with above. */ + if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED) { tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); if (huge_cst) diff --git a/gcc/testsuite/gfortran.dg/unsigned_34.f90 b/gcc/testsuite/gfortran.dg/unsigned_34.f90 new file mode 100644 index 00000000000..238f11a6e58 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_34.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program memain + implicit none + call test1 + call test2 +contains + subroutine test1 + unsigned, dimension(3) :: v + unsigned :: t1, t2 + unsigned(2), dimension(3,3) :: w + integer, dimension(3,3) :: j + integer :: di + v = [1u, 2u, 4294967286u] + t1 = maxval(v,dim=1) + if (t1 /= 4294967286u) error stop 1 + t2 = minval(v,dim=1) + if (t2 /= 1u) error stop 2 + call check_empty(0) + j = reshape([1,2,3,65534,5,1,65000,2,1],[3,3]) + w = uint(j,2) + if (any(maxval(j,dim=1) /= int(maxval(w,dim=1)))) error stop 5 + di = 2 + if (any(maxval(j,dim=di) /= int(maxval(w,dim=di)))) error stop 6 + end subroutine test1 + subroutine check_empty(n) + integer, intent(in) :: n + unsigned, dimension(n) :: empty + if (minval(empty,dim=1) /= 4294967295u) error stop 3 + if (maxval(empty,dim=1) /= 0u) error stop 4 + end subroutine check_empty + subroutine test2 + integer :: i + unsigned, dimension(3), parameter :: v = [1u, 2u, 4294967286u] + unsigned, parameter :: t1 = maxval(v,dim=1) + unsigned, parameter :: t2 = minval(v,dim=1) + unsigned, parameter, dimension(2:1) :: empty = [(0u,i=2,1)] + unsigned, parameter :: t3 = minval(empty,1) + unsigned, parameter :: t4 = maxval(empty,1) + unsigned(2), parameter, dimension(2:1,2:1) :: e2 = reshape(empty,[0,0]) + integer, parameter, dimension(3,3) :: j = reshape([1,2,3,65534,5,1,65000,2,1],[3,3]) + integer, parameter, dimension(3) :: maxvj = maxval(j,1), minvj=minval(j,2) + unsigned, parameter, dimension(3,3) :: w = uint(j,2) + unsigned(2), parameter, dimension(3) :: maxvw = maxval(w,1), minvw = minval(w,2) + + if (t1 /= 4294967286u) error stop 11 + if (t2 /= 1u) error stop 12 + if (t3 /= 4294967295u) error stop 13 + if (t4 /= 0u) error stop 14 + if (any(maxvj /= int(maxvw))) error stop 15 + if (any(minvj /= int(minvw))) error stop 16 + end subroutine test2 +end program memain diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 8524cc6ed03..1564e2abcde 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -428,6 +428,11 @@ generated/maxval_i2.c \ generated/maxval_i4.c \ generated/maxval_i8.c \ generated/maxval_i16.c \ +generated/maxval_m1.c \ +generated/maxval_m2.c \ +generated/maxval_m4.c \ +generated/maxval_m8.c \ +generated/maxval_m16.c \ generated/maxval_r4.c \ generated/maxval_r8.c \ generated/maxval_r10.c \ @@ -536,6 +541,11 @@ generated/minval_i2.c \ generated/minval_i4.c \ generated/minval_i8.c \ generated/minval_i16.c \ +generated/minval_m1.c \ +generated/minval_m2.c \ +generated/minval_m4.c \ +generated/minval_m8.c \ +generated/minval_m16.c \ generated/minval_r4.c \ generated/minval_r8.c \ generated/minval_r10.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 6c6c89cc14e..d850c2ec314 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -270,9 +270,12 @@ am__objects_8 = generated/maxloc1_4_i1.lo generated/maxloc1_8_i1.lo \ generated/maxloc1_8_r17.lo generated/maxloc1_16_r17.lo am__objects_9 = generated/maxval_i1.lo generated/maxval_i2.lo \ generated/maxval_i4.lo generated/maxval_i8.lo \ - generated/maxval_i16.lo generated/maxval_r4.lo \ - generated/maxval_r8.lo generated/maxval_r10.lo \ - generated/maxval_r16.lo generated/maxval_r17.lo + generated/maxval_i16.lo generated/maxval_m1.lo \ + generated/maxval_m2.lo generated/maxval_m4.lo \ + generated/maxval_m8.lo generated/maxval_m16.lo \ + generated/maxval_r4.lo generated/maxval_r8.lo \ + generated/maxval_r10.lo generated/maxval_r16.lo \ + generated/maxval_r17.lo am__objects_10 = generated/minloc0_4_i1.lo generated/minloc0_8_i1.lo \ generated/minloc0_16_i1.lo generated/minloc0_4_i2.lo \ generated/minloc0_8_i2.lo generated/minloc0_16_i2.lo \ @@ -305,9 +308,12 @@ am__objects_11 = generated/minloc1_4_i1.lo generated/minloc1_8_i1.lo \ generated/minloc1_8_r17.lo generated/minloc1_16_r17.lo am__objects_12 = generated/minval_i1.lo generated/minval_i2.lo \ generated/minval_i4.lo generated/minval_i8.lo \ - generated/minval_i16.lo generated/minval_r4.lo \ - generated/minval_r8.lo generated/minval_r10.lo \ - generated/minval_r16.lo generated/minval_r17.lo + generated/minval_i16.lo generated/minval_m1.lo \ + generated/minval_m2.lo generated/minval_m4.lo \ + generated/minval_m8.lo generated/minval_m16.lo \ + generated/minval_r4.lo generated/minval_r8.lo \ + generated/minval_r10.lo generated/minval_r16.lo \ + generated/minval_r17.lo am__objects_13 = generated/product_i1.lo generated/product_i2.lo \ generated/product_i4.lo generated/product_i8.lo \ generated/product_i16.lo generated/product_r4.lo \ @@ -1186,6 +1192,11 @@ generated/maxval_i2.c \ generated/maxval_i4.c \ generated/maxval_i8.c \ generated/maxval_i16.c \ +generated/maxval_m1.c \ +generated/maxval_m2.c \ +generated/maxval_m4.c \ +generated/maxval_m8.c \ +generated/maxval_m16.c \ generated/maxval_r4.c \ generated/maxval_r8.c \ generated/maxval_r10.c \ @@ -1294,6 +1305,11 @@ generated/minval_i2.c \ generated/minval_i4.c \ generated/minval_i8.c \ generated/minval_i16.c \ +generated/minval_m1.c \ +generated/minval_m2.c \ +generated/minval_m4.c \ +generated/minval_m8.c \ +generated/minval_m16.c \ generated/minval_r4.c \ generated/minval_r8.c \ generated/minval_r10.c \ @@ -2194,6 +2210,16 @@ generated/maxval_i8.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxval_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) +generated/maxval_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxval_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxval_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxval_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxval_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) generated/maxval_r4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxval_r8.lo: generated/$(am__dirstamp) \ @@ -2334,6 +2360,16 @@ generated/minval_i8.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minval_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) +generated/minval_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minval_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minval_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minval_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minval_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) generated/minval_r4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minval_r8.lo: generated/$(am__dirstamp) \ @@ -3910,6 +3946,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxval_r17.Plo@am__quote@ @@ -4002,6 +4043,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minval_r17.Plo@am__quote@ diff --git a/libgfortran/generated/maxval_m1.c b/libgfortran/generated/maxval_m1.c new file mode 100644 index 00000000000..051647d2fbe --- /dev/null +++ b/libgfortran/generated/maxval_m1.c @@ -0,0 +1,562 @@ +/* Implementation of the MAXVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1) + + +extern void maxval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict); +export_proto(maxval_m1); + +void +maxval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_UINTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_UINTEGER_1 result; + src = base; + { + +#if defined (GFC_UINTEGER_1_INFINITY) + result = -GFC_UINTEGER_1_INFINITY; +#else + result = -GFC_UINTEGER_1_HUGE; +#endif + if (len <= 0) + *dest = -GFC_UINTEGER_1_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_1_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src > result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_m1); + +void +mmaxval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_1 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxval_m1 (retarray, array, pdim, back); +#else + maxval_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_1 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_1_INFINITY) + result = -GFC_UINTEGER_1_INFINITY; +#else + result = -GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_1_INFINITY) || defined (GFC_UINTEGER_1_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_1_QUIET_NAN : -GFC_UINTEGER_1_HUGE; +#else + result = -GFC_UINTEGER_1_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_m1); + +void +smaxval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxval_m1 (retarray, array, pdim, back); +#else + maxval_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MAXVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = -GFC_UINTEGER_1_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_m16.c b/libgfortran/generated/maxval_m16.c new file mode 100644 index 00000000000..29e2c8d427b --- /dev/null +++ b/libgfortran/generated/maxval_m16.c @@ -0,0 +1,562 @@ +/* Implementation of the MAXVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_UINTEGER_16) + + +extern void maxval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict); +export_proto(maxval_m16); + +void +maxval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_UINTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_UINTEGER_16 result; + src = base; + { + +#if defined (GFC_UINTEGER_16_INFINITY) + result = -GFC_UINTEGER_16_INFINITY; +#else + result = -GFC_UINTEGER_16_HUGE; +#endif + if (len <= 0) + *dest = -GFC_UINTEGER_16_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src > result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_m16); + +void +mmaxval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_16 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxval_m16 (retarray, array, pdim, back); +#else + maxval_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_16_INFINITY) + result = -GFC_UINTEGER_16_INFINITY; +#else + result = -GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_16_INFINITY) || defined (GFC_UINTEGER_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_16_QUIET_NAN : -GFC_UINTEGER_16_HUGE; +#else + result = -GFC_UINTEGER_16_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_m16); + +void +smaxval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxval_m16 (retarray, array, pdim, back); +#else + maxval_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MAXVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = -GFC_UINTEGER_16_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_m2.c b/libgfortran/generated/maxval_m2.c new file mode 100644 index 00000000000..d432e78ba23 --- /dev/null +++ b/libgfortran/generated/maxval_m2.c @@ -0,0 +1,562 @@ +/* Implementation of the MAXVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_UINTEGER_2) + + +extern void maxval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict); +export_proto(maxval_m2); + +void +maxval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_UINTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_UINTEGER_2 result; + src = base; + { + +#if defined (GFC_UINTEGER_2_INFINITY) + result = -GFC_UINTEGER_2_INFINITY; +#else + result = -GFC_UINTEGER_2_HUGE; +#endif + if (len <= 0) + *dest = -GFC_UINTEGER_2_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_2_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src > result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_m2); + +void +mmaxval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_2 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxval_m2 (retarray, array, pdim, back); +#else + maxval_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_2 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_2_INFINITY) + result = -GFC_UINTEGER_2_INFINITY; +#else + result = -GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_2_INFINITY) || defined (GFC_UINTEGER_2_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_2_QUIET_NAN : -GFC_UINTEGER_2_HUGE; +#else + result = -GFC_UINTEGER_2_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_m2); + +void +smaxval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxval_m2 (retarray, array, pdim, back); +#else + maxval_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MAXVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = -GFC_UINTEGER_2_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_m4.c b/libgfortran/generated/maxval_m4.c new file mode 100644 index 00000000000..1aa4368b896 --- /dev/null +++ b/libgfortran/generated/maxval_m4.c @@ -0,0 +1,562 @@ +/* Implementation of the MAXVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4) + + +extern void maxval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict); +export_proto(maxval_m4); + +void +maxval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_UINTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_UINTEGER_4 result; + src = base; + { + +#if defined (GFC_UINTEGER_4_INFINITY) + result = -GFC_UINTEGER_4_INFINITY; +#else + result = -GFC_UINTEGER_4_HUGE; +#endif + if (len <= 0) + *dest = -GFC_UINTEGER_4_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src > result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_m4); + +void +mmaxval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_4 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxval_m4 (retarray, array, pdim, back); +#else + maxval_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_4_INFINITY) + result = -GFC_UINTEGER_4_INFINITY; +#else + result = -GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_4_INFINITY) || defined (GFC_UINTEGER_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_4_QUIET_NAN : -GFC_UINTEGER_4_HUGE; +#else + result = -GFC_UINTEGER_4_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_m4); + +void +smaxval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxval_m4 (retarray, array, pdim, back); +#else + maxval_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MAXVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = -GFC_UINTEGER_4_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_m8.c b/libgfortran/generated/maxval_m8.c new file mode 100644 index 00000000000..3e2d1a95cea --- /dev/null +++ b/libgfortran/generated/maxval_m8.c @@ -0,0 +1,562 @@ +/* Implementation of the MAXVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_UINTEGER_8) + + +extern void maxval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict); +export_proto(maxval_m8); + +void +maxval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_UINTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_UINTEGER_8 result; + src = base; + { + +#if defined (GFC_UINTEGER_8_INFINITY) + result = -GFC_UINTEGER_8_INFINITY; +#else + result = -GFC_UINTEGER_8_HUGE; +#endif + if (len <= 0) + *dest = -GFC_UINTEGER_8_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src > result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_m8); + +void +mmaxval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_8 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxval_m8 (retarray, array, pdim, back); +#else + maxval_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_8_INFINITY) + result = -GFC_UINTEGER_8_INFINITY; +#else + result = -GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_8_INFINITY) || defined (GFC_UINTEGER_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_8_QUIET_NAN : -GFC_UINTEGER_8_HUGE; +#else + result = -GFC_UINTEGER_8_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src > result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_m8); + +void +smaxval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxval_m8 (retarray, array, pdim, back); +#else + maxval_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MAXVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = -GFC_UINTEGER_8_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_m1.c b/libgfortran/generated/minval_m1.c new file mode 100644 index 00000000000..7a796f1228c --- /dev/null +++ b/libgfortran/generated/minval_m1.c @@ -0,0 +1,562 @@ +/* Implementation of the MINVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1) + + +extern void minval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict); +export_proto(minval_m1); + +void +minval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_UINTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_UINTEGER_1 result; + src = base; + { + +#if defined (GFC_UINTEGER_1_INFINITY) + result = GFC_UINTEGER_1_INFINITY; +#else + result = GFC_UINTEGER_1_HUGE; +#endif + if (len <= 0) + *dest = GFC_UINTEGER_1_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_1_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src < result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_m1); + +void +mminval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_1 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minval_m1 (retarray, array, pdim, back); +#else + minval_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_1 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_1_INFINITY) + result = GFC_UINTEGER_1_INFINITY; +#else + result = GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_1_INFINITY) || defined (GFC_UINTEGER_1_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_1_QUIET_NAN : GFC_UINTEGER_1_HUGE; +#else + result = GFC_UINTEGER_1_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminval_m1 (gfc_array_m1 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_m1); + +void +sminval_m1 (gfc_array_m1 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minval_m1 (retarray, array, pdim, back); +#else + minval_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MINVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = GFC_UINTEGER_1_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_m16.c b/libgfortran/generated/minval_m16.c new file mode 100644 index 00000000000..c2d5a13a4db --- /dev/null +++ b/libgfortran/generated/minval_m16.c @@ -0,0 +1,562 @@ +/* Implementation of the MINVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_UINTEGER_16) + + +extern void minval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict); +export_proto(minval_m16); + +void +minval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_UINTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_UINTEGER_16 result; + src = base; + { + +#if defined (GFC_UINTEGER_16_INFINITY) + result = GFC_UINTEGER_16_INFINITY; +#else + result = GFC_UINTEGER_16_HUGE; +#endif + if (len <= 0) + *dest = GFC_UINTEGER_16_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src < result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_m16); + +void +mminval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_16 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minval_m16 (retarray, array, pdim, back); +#else + minval_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_16_INFINITY) + result = GFC_UINTEGER_16_INFINITY; +#else + result = GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_16_INFINITY) || defined (GFC_UINTEGER_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_16_QUIET_NAN : GFC_UINTEGER_16_HUGE; +#else + result = GFC_UINTEGER_16_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminval_m16 (gfc_array_m16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_m16); + +void +sminval_m16 (gfc_array_m16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minval_m16 (retarray, array, pdim, back); +#else + minval_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MINVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = GFC_UINTEGER_16_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_m2.c b/libgfortran/generated/minval_m2.c new file mode 100644 index 00000000000..f40bbfd7df2 --- /dev/null +++ b/libgfortran/generated/minval_m2.c @@ -0,0 +1,562 @@ +/* Implementation of the MINVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_UINTEGER_2) + + +extern void minval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict); +export_proto(minval_m2); + +void +minval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_UINTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_UINTEGER_2 result; + src = base; + { + +#if defined (GFC_UINTEGER_2_INFINITY) + result = GFC_UINTEGER_2_INFINITY; +#else + result = GFC_UINTEGER_2_HUGE; +#endif + if (len <= 0) + *dest = GFC_UINTEGER_2_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_2_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src < result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_m2); + +void +mminval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_2 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minval_m2 (retarray, array, pdim, back); +#else + minval_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_2 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_2_INFINITY) + result = GFC_UINTEGER_2_INFINITY; +#else + result = GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_2_INFINITY) || defined (GFC_UINTEGER_2_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_2_QUIET_NAN : GFC_UINTEGER_2_HUGE; +#else + result = GFC_UINTEGER_2_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminval_m2 (gfc_array_m2 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_m2); + +void +sminval_m2 (gfc_array_m2 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minval_m2 (retarray, array, pdim, back); +#else + minval_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_2)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MINVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = GFC_UINTEGER_2_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_m4.c b/libgfortran/generated/minval_m4.c new file mode 100644 index 00000000000..e6616a28db1 --- /dev/null +++ b/libgfortran/generated/minval_m4.c @@ -0,0 +1,562 @@ +/* Implementation of the MINVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4) + + +extern void minval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict); +export_proto(minval_m4); + +void +minval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_UINTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_UINTEGER_4 result; + src = base; + { + +#if defined (GFC_UINTEGER_4_INFINITY) + result = GFC_UINTEGER_4_INFINITY; +#else + result = GFC_UINTEGER_4_HUGE; +#endif + if (len <= 0) + *dest = GFC_UINTEGER_4_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src < result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_m4); + +void +mminval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_4 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minval_m4 (retarray, array, pdim, back); +#else + minval_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_4_INFINITY) + result = GFC_UINTEGER_4_INFINITY; +#else + result = GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_4_INFINITY) || defined (GFC_UINTEGER_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_4_QUIET_NAN : GFC_UINTEGER_4_HUGE; +#else + result = GFC_UINTEGER_4_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminval_m4 (gfc_array_m4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_m4); + +void +sminval_m4 (gfc_array_m4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minval_m4 (retarray, array, pdim, back); +#else + minval_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MINVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = GFC_UINTEGER_4_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_m8.c b/libgfortran/generated/minval_m8.c new file mode 100644 index 00000000000..62f909dc1d9 --- /dev/null +++ b/libgfortran/generated/minval_m8.c @@ -0,0 +1,562 @@ +/* Implementation of the MINVAL intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 of the License, 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 +. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_UINTEGER_8) + + +extern void minval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict); +export_proto(minval_m8); + +void +minval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_UINTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_UINTEGER_8 result; + src = base; + { + +#if defined (GFC_UINTEGER_8_INFINITY) + result = GFC_UINTEGER_8_INFINITY; +#else + result = GFC_UINTEGER_8_HUGE; +#endif + if (len <= 0) + *dest = GFC_UINTEGER_8_HUGE; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_UINTEGER_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + if (*src < result) + result = *src; + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_m8); + +void +mminval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_8 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minval_m8 (retarray, array, pdim, back); +#else + minval_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_UINTEGER_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_UINTEGER_8_INFINITY) + result = GFC_UINTEGER_8_INFINITY; +#else + result = GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + int non_empty_p = 0; +#endif + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_UINTEGER_8_INFINITY) || defined (GFC_UINTEGER_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + result = non_empty_p ? GFC_UINTEGER_8_QUIET_NAN : GFC_UINTEGER_8_HUGE; +#else + result = GFC_UINTEGER_8_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + if (*msrc && *src < result) + result = *src; + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminval_m8 (gfc_array_m8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_m8); + +void +sminval_m8 (gfc_array_m8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_UINTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minval_m8 (retarray, array, pdim, back); +#else + minval_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (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" + " MINVAL 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++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = GFC_UINTEGER_8_HUGE; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 6c42b167430..ebde691ae4f 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1787,4 +1787,34 @@ GFORTRAN_15 { _gfortran_arandom_m4; _gfortran_arandom_m8; _gfortran_arandom_m16; + _gfortran_minval_m16; + _gfortran_minval_m1; + _gfortran_minval_m2; + _gfortran_minval_m4; + _gfortran_minval_m8; + _gfortran_mminval_m16; + _gfortran_mminval_m1; + _gfortran_mminval_m2; + _gfortran_mminval_m4; + _gfortran_mminval_m8; + _gfortran_sminval_m16; + _gfortran_sminval_m1; + _gfortran_sminval_m2; + _gfortran_sminval_m4; + _gfortran_sminval_m8; + _gfortran_maxval_m16; + _gfortran_maxval_m1; + _gfortran_maxval_m2; + _gfortran_maxval_m4; + _gfortran_maxval_m8; + _gfortran_mmaxval_m16; + _gfortran_mmaxval_m1; + _gfortran_mmaxval_m2; + _gfortran_mmaxval_m4; + _gfortran_mmaxval_m8; + _gfortran_smaxval_m16; + _gfortran_smaxval_m1; + _gfortran_smaxval_m2; + _gfortran_smaxval_m4; + _gfortran_smaxval_m8; } GFORTRAN_14;