diff options
Diffstat (limited to 'libgfortran')
167 files changed, 11891 insertions, 2911 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 8ef3e0fc55e..26ad0395b64 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,334 @@ +2008-05-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/36131 + * io/transfer.c (formatted_transfer_scalar): Revert patch for PR34974. + (next_record_w): Likewise. + +2008-05-04 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35995 + * m4/ifunction_logical.m4: If the extent of "array" + is less than zero, set it to zero. Use an explicit + flag for breaking out of the main loop to avoid, because + the data pointer for "array" may be NULL for an empty + array. + * m4/ifunction.m4: Likewise. + * generated/all_l1.c: Regenerated. + * generated/all_l16.c: Regenerated. + * generated/all_l2.c: Regenerated. + * generated/all_l4.c: Regenerated. + * generated/all_l8.c: Regenerated. + * generated/any_l1.c: Regenerated. + * generated/any_l16.c: Regenerated. + * generated/any_l2.c: Regenerated. + * generated/any_l4.c: Regenerated. + * generated/any_l8.c: Regenerated. + * generated/count_16_l.c: Regenerated. + * generated/count_1_l.c: Regenerated. + * generated/count_2_l.c: Regenerated. + * generated/count_4_l.c: Regenerated. + * generated/count_8_l.c: Regenerated. + * generated/maxloc1_16_i1.c: Regenerated. + * generated/maxloc1_16_i16.c: Regenerated. + * generated/maxloc1_16_i2.c: Regenerated. + * generated/maxloc1_16_i4.c: Regenerated. + * generated/maxloc1_16_i8.c: Regenerated. + * generated/maxloc1_16_r10.c: Regenerated. + * generated/maxloc1_16_r16.c: Regenerated. + * generated/maxloc1_16_r4.c: Regenerated. + * generated/maxloc1_16_r8.c: Regenerated. + * generated/maxloc1_4_i1.c: Regenerated. + * generated/maxloc1_4_i16.c: Regenerated. + * generated/maxloc1_4_i2.c: Regenerated. + * generated/maxloc1_4_i4.c: Regenerated. + * generated/maxloc1_4_i8.c: Regenerated. + * generated/maxloc1_4_r10.c: Regenerated. + * generated/maxloc1_4_r16.c: Regenerated. + * generated/maxloc1_4_r4.c: Regenerated. + * generated/maxloc1_4_r8.c: Regenerated. + * generated/maxloc1_8_i1.c: Regenerated. + * generated/maxloc1_8_i16.c: Regenerated. + * generated/maxloc1_8_i2.c: Regenerated. + * generated/maxloc1_8_i4.c: Regenerated. + * generated/maxloc1_8_i8.c: Regenerated. + * generated/maxloc1_8_r10.c: Regenerated. + * generated/maxloc1_8_r16.c: Regenerated. + * generated/maxloc1_8_r4.c: Regenerated. + * generated/maxloc1_8_r8.c: Regenerated. + * generated/maxval_i1.c: Regenerated. + * generated/maxval_i16.c: Regenerated. + * generated/maxval_i2.c: Regenerated. + * generated/maxval_i4.c: Regenerated. + * generated/maxval_i8.c: Regenerated. + * generated/maxval_r10.c: Regenerated. + * generated/maxval_r16.c: Regenerated. + * generated/maxval_r4.c: Regenerated. + * generated/maxval_r8.c: Regenerated. + * generated/minloc1_16_i1.c: Regenerated. + * generated/minloc1_16_i16.c: Regenerated. + * generated/minloc1_16_i2.c: Regenerated. + * generated/minloc1_16_i4.c: Regenerated. + * generated/minloc1_16_i8.c: Regenerated. + * generated/minloc1_16_r10.c: Regenerated. + * generated/minloc1_16_r16.c: Regenerated. + * generated/minloc1_16_r4.c: Regenerated. + * generated/minloc1_16_r8.c: Regenerated. + * generated/minloc1_4_i1.c: Regenerated. + * generated/minloc1_4_i16.c: Regenerated. + * generated/minloc1_4_i2.c: Regenerated. + * generated/minloc1_4_i4.c: Regenerated. + * generated/minloc1_4_i8.c: Regenerated. + * generated/minloc1_4_r10.c: Regenerated. + * generated/minloc1_4_r16.c: Regenerated. + * generated/minloc1_4_r4.c: Regenerated. + * generated/minloc1_4_r8.c: Regenerated. + * generated/minloc1_8_i1.c: Regenerated. + * generated/minloc1_8_i16.c: Regenerated. + * generated/minloc1_8_i2.c: Regenerated. + * generated/minloc1_8_i4.c: Regenerated. + * generated/minloc1_8_i8.c: Regenerated. + * generated/minloc1_8_r10.c: Regenerated. + * generated/minloc1_8_r16.c: Regenerated. + * generated/minloc1_8_r4.c: Regenerated. + * generated/minloc1_8_r8.c: Regenerated. + * generated/minval_i1.c: Regenerated. + * generated/minval_i16.c: Regenerated. + * generated/minval_i2.c: Regenerated. + * generated/minval_i4.c: Regenerated. + * generated/minval_i8.c: Regenerated. + * generated/minval_r10.c: Regenerated. + * generated/minval_r16.c: Regenerated. + * generated/minval_r4.c: Regenerated. + * generated/minval_r8.c: Regenerated. + * generated/product_c10.c: Regenerated. + * generated/product_c16.c: Regenerated. + * generated/product_c4.c: Regenerated. + * generated/product_c8.c: Regenerated. + * generated/product_i1.c: Regenerated. + * generated/product_i16.c: Regenerated. + * generated/product_i2.c: Regenerated. + * generated/product_i4.c: Regenerated. + * generated/product_i8.c: Regenerated. + * generated/product_r10.c: Regenerated. + * generated/product_r16.c: Regenerated. + * generated/product_r4.c: Regenerated. + * generated/product_r8.c: Regenerated. + * generated/sum_c10.c: Regenerated. + * generated/sum_c16.c: Regenerated. + * generated/sum_c4.c: Regenerated. + * generated/sum_c8.c: Regenerated. + * generated/sum_i1.c: Regenerated. + * generated/sum_i16.c: Regenerated. + * generated/sum_i2.c: Regenerated. + * generated/sum_i4.c: Regenerated. + * generated/sum_i8.c: Regenerated. + * generated/sum_r10.c: Regenerated. + * generated/sum_r16.c: Regenerated. + * generated/sum_r4.c: Regenerated. + * generated/sum_r8.c: Regenerated. + +2008-05-04 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35990 + * intrinsics/pack_generic.c: Really commit. + +2008-05-04 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35990 + * intrinsics/pack_generic.c: If an extent of the source + array is less then zero, set it to zero. Set the source + pointer to NULL if the source size is zero. Set the total + number of elements to zero if the vector has an extent + less or equal to zero. + * m4/pack.m4: Set the source pointer to NULL if the + source array is zero-sized. Set the total number of + elemements to zero if the vector has an extent less or + equal to zero. + * generated/pack_i1.c: Regenerated. + * generated/pack_i2.c: Regenerated. + * generated/pack_i4.c: Regenerated. + * generated/pack_i8.c: Regenerated. + * generated/pack_i16.c: Regenerated. + * generated/pack_r4.c: Regenerated. + * generated/pack_r8.c: Regenerated. + * generated/pack_r10.c: Regenerated. + * generated/pack_r16.c: Regenerated. + * generated/pack_c4.c: Regenerated. + * generated/pack_c8.c: Regenerated. + * generated/pack_c10.c: Regenerated. + * generated/pack_c16.c: Regenerated. + +2008-05-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/36094 + * runtime/error.c (show_locus): Provide modified error message when + filename has not yet been associated with a unit number. + * io/open.c (encoding_opt[]): Comment out "utf-8" option and add TODO. + +2008-04-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsics/selected_char_kind.c: New file. + * gfortran.map (GFORTRAN_1.1): Add _gfortran_selected_char_kind. + * Makefile.am: Add intrinsics/selected_char_kind.c. + * Makefile.in: Regenerate. + +2008-04-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35993 + * ifunction.m4 (SCALAR_ARRAY_FUNCTION): Use correct + implementation for multi-dimensional return arrays when + the mask is .false. + * generated/maxloc1_16_i1.c: Regenerated. + * generated/maxloc1_16_i16.c: Regenerated. + * generated/maxloc1_16_i2.c: Regenerated. + * generated/maxloc1_16_i4.c: Regenerated. + * generated/maxloc1_16_i8.c: Regenerated. + * generated/maxloc1_16_r10.c: Regenerated. + * generated/maxloc1_16_r16.c: Regenerated. + * generated/maxloc1_16_r4.c: Regenerated. + * generated/maxloc1_16_r8.c: Regenerated. + * generated/maxloc1_4_i1.c: Regenerated. + * generated/maxloc1_4_i16.c: Regenerated. + * generated/maxloc1_4_i2.c: Regenerated. + * generated/maxloc1_4_i4.c: Regenerated. + * generated/maxloc1_4_i8.c: Regenerated. + * generated/maxloc1_4_r10.c: Regenerated. + * generated/maxloc1_4_r16.c: Regenerated. + * generated/maxloc1_4_r4.c: Regenerated. + * generated/maxloc1_4_r8.c: Regenerated. + * generated/maxloc1_8_i1.c: Regenerated. + * generated/maxloc1_8_i16.c: Regenerated. + * generated/maxloc1_8_i2.c: Regenerated. + * generated/maxloc1_8_i4.c: Regenerated. + * generated/maxloc1_8_i8.c: Regenerated. + * generated/maxloc1_8_r10.c: Regenerated. + * generated/maxloc1_8_r16.c: Regenerated. + * generated/maxloc1_8_r4.c: Regenerated. + * generated/maxloc1_8_r8.c: Regenerated. + * generated/maxval_i1.c: Regenerated. + * generated/maxval_i16.c: Regenerated. + * generated/maxval_i2.c: Regenerated. + * generated/maxval_i4.c: Regenerated. + * generated/maxval_i8.c: Regenerated. + * generated/maxval_r10.c: Regenerated. + * generated/maxval_r16.c: Regenerated. + * generated/maxval_r4.c: Regenerated. + * generated/maxval_r8.c: Regenerated. + * generated/minloc1_16_i1.c: Regenerated. + * generated/minloc1_16_i16.c: Regenerated. + * generated/minloc1_16_i2.c: Regenerated. + * generated/minloc1_16_i4.c: Regenerated. + * generated/minloc1_16_i8.c: Regenerated. + * generated/minloc1_16_r10.c: Regenerated. + * generated/minloc1_16_r16.c: Regenerated. + * generated/minloc1_16_r4.c: Regenerated. + * generated/minloc1_16_r8.c: Regenerated. + * generated/minloc1_4_i1.c: Regenerated. + * generated/minloc1_4_i16.c: Regenerated. + * generated/minloc1_4_i2.c: Regenerated. + * generated/minloc1_4_i4.c: Regenerated. + * generated/minloc1_4_i8.c: Regenerated. + * generated/minloc1_4_r10.c: Regenerated. + * generated/minloc1_4_r16.c: Regenerated. + * generated/minloc1_4_r4.c: Regenerated. + * generated/minloc1_4_r8.c: Regenerated. + * generated/minloc1_8_i1.c: Regenerated. + * generated/minloc1_8_i16.c: Regenerated. + * generated/minloc1_8_i2.c: Regenerated. + * generated/minloc1_8_i4.c: Regenerated. + * generated/minloc1_8_i8.c: Regenerated. + * generated/minloc1_8_r10.c: Regenerated. + * generated/minloc1_8_r16.c: Regenerated. + * generated/minloc1_8_r4.c: Regenerated. + * generated/minloc1_8_r8.c: Regenerated. + * generated/minval_i1.c: Regenerated. + * generated/minval_i16.c: Regenerated. + * generated/minval_i2.c: Regenerated. + * generated/minval_i4.c: Regenerated. + * generated/minval_i8.c: Regenerated. + * generated/minval_r10.c: Regenerated. + * generated/minval_r16.c: Regenerated. + * generated/minval_r4.c: Regenerated. + * generated/minval_r8.c: Regenerated. + * generated/product_c10.c: Regenerated. + * generated/product_c16.c: Regenerated. + * generated/product_c4.c: Regenerated. + * generated/product_c8.c: Regenerated. + * generated/product_i1.c: Regenerated. + * generated/product_i16.c: Regenerated. + * generated/product_i2.c: Regenerated. + * generated/product_i4.c: Regenerated. + * generated/product_i8.c: Regenerated. + * generated/product_r10.c: Regenerated. + * generated/product_r16.c: Regenerated. + * generated/product_r4.c: Regenerated. + * generated/product_r8.c: Regenerated. + * generated/sum_c10.c: Regenerated. + * generated/sum_c16.c: Regenerated. + * generated/sum_c4.c: Regenerated. + * generated/sum_c8.c: Regenerated. + * generated/sum_i1.c: Regenerated. + * generated/sum_i16.c: Regenerated. + * generated/sum_i2.c: Regenerated. + * generated/sum_i4.c: Regenerated. + * generated/sum_i8.c: Regenerated. + * generated/sum_r10.c: Regenerated. + * generated/sum_r16.c: Regenerated. + * generated/sum_r4.c: Regenerated. + * generated/sum_r8.c: Regenerated. + +2008-04-25 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35960 + * m4/reshape.m4: Fix typo in last commit. + * generated/reshape_i4.c: Regererated. + * generated/reshape_i8.c: Regenerated. + * generated/reshape_i16.c: Regenerated. + * generated/reshape_r4.c: Regenerated. + * generated/reshape_r8.c: Regenerated. + * generated/reshape_r10.c: Regenerated. + * generated/reshape_r16.c: Regenerated. + * generated/reshape_c4.c: Regenerated. + * generated/reshape_c8.c: Regenerated. + * generated/reshape_c10.c: Regenerated. + * generated/reshape_c16.c: Regenerated. + +2008-04-24 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsics/time_1.h (__time_1): Remove unused variable. + +2008-04-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/35988 + * m4/matmul.m4: Only issue a runtime error if extents are + non-zero. + * generated/matmul_i1.c: Regenerated. + * generated/matmul_i2.c: Regenerated. + * generated/matmul_i4.c: Regenerated. + * generated/matmul_i8.c: Regenerated. + * generated/matmul_i16.c: Regenerated. + * generated/matmul_r4.c: Regenerated. + * generated/matmul_r8.c: Regenerated. + * generated/matmul_r10.c: Regenerated. + * generated/matmul_r16.c: Regenerated. + * generated/matmul_c4.c: Regenerated. + * generated/matmul_c8.c: Regenerated. + * generated/matmul_c10.c: Regenerated. + * generated/matmul_c16.c: Regenerated. + +2008-04-21 Ralf Wildenhues <Ralf.Wildenhues@gmx.de> + + * acinclude.m4 (LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY) + (LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT) + (LIBGFOR_CHECK_ATTRIBUTE_ALIAS, LIBGFOR_CHECK_SYNC_FETCH_AND_ADD) + (LIBGFOR_GTHREAD_WEAK, LIBGFOR_CHECK_UNLINK_OPEN_FILE) + (LIBGFOR_CHECK_CRLF, LIBGFOR_CHECK_FOR_BROKEN_ISFINITE) + (LIBGFOR_CHECK_FOR_BROKEN_ISNAN) + (LIBGFOR_CHECK_FOR_BROKEN_FPCLASSIFY, LIBGFOR_CHECK_WORKING_STAT) + (LIBGFOR_CHECK_FPSETMASK, LIBGFOR_CHECK_MINGW_SNPRINTF): + Fix cache variable names. + * configure, Makefile.in: Regenerate. + 2008-04-20 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR fortran/35991 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 62ae5f31db8..93a4072d7d8 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -87,6 +87,7 @@ intrinsics/mvbits.c \ intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ +intrinsics/selected_char_kind.c \ intrinsics/signal.c \ intrinsics/size.c \ intrinsics/sleep.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 71eb44e23df..686308a7fa0 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -51,6 +51,7 @@ ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/../config/depstand.m4 \ $(top_srcdir)/../config/lead-dot.m4 \ $(top_srcdir)/../config/multi.m4 \ + $(top_srcdir)/../config/override.m4 \ $(top_srcdir)/../config/proginstall.m4 \ $(top_srcdir)/../config/stdint.m4 \ $(top_srcdir)/../ltoptions.m4 $(top_srcdir)/../ltsugar.m4 \ @@ -415,7 +416,8 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \ intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \ intrinsics/mvbits.c intrinsics/move_alloc.c \ intrinsics/pack_generic.c intrinsics/perror.c \ - intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \ + intrinsics/selected_char_kind.c intrinsics/signal.c \ + intrinsics/size.c intrinsics/sleep.c \ intrinsics/spread_generic.c intrinsics/string_intrinsics.c \ intrinsics/system.c intrinsics/rand.c intrinsics/random.c \ intrinsics/rename.c intrinsics/reshape_generic.c \ @@ -697,12 +699,12 @@ am__objects_35 = associated.lo abort.lo access.lo args.lo \ fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \ ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \ kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \ - pack_generic.lo perror.lo signal.lo size.lo sleep.lo \ - spread_generic.lo string_intrinsics.lo system.lo rand.lo \ - random.lo rename.lo reshape_generic.lo reshape_packed.lo \ - selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ - system_clock.lo time.lo transpose_generic.lo umask.lo \ - unlink.lo unpack_generic.lo in_pack_generic.lo \ + pack_generic.lo perror.lo selected_char_kind.lo signal.lo \ + size.lo sleep.lo spread_generic.lo string_intrinsics.lo \ + system.lo rand.lo random.lo rename.lo reshape_generic.lo \ + reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ + stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \ + umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo am__objects_36 = am__objects_37 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ @@ -985,6 +987,7 @@ intrinsics/mvbits.c \ intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ intrinsics/perror.c \ +intrinsics/selected_char_kind.c \ intrinsics/signal.c \ intrinsics/size.c \ intrinsics/sleep.c \ @@ -2072,6 +2075,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/select.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/selected_char_kind.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r4.Plo@am__quote@ @@ -5371,6 +5375,13 @@ perror.lo: intrinsics/perror.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o perror.lo `test -f 'intrinsics/perror.c' || echo '$(srcdir)/'`intrinsics/perror.c +selected_char_kind.lo: intrinsics/selected_char_kind.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT selected_char_kind.lo -MD -MP -MF "$(DEPDIR)/selected_char_kind.Tpo" -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/selected_char_kind.Tpo" "$(DEPDIR)/selected_char_kind.Plo"; else rm -f "$(DEPDIR)/selected_char_kind.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/selected_char_kind.c' object='selected_char_kind.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c + signal.lo: intrinsics/signal.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT signal.lo -MD -MP -MF "$(DEPDIR)/signal.Tpo" -c -o signal.lo `test -f 'intrinsics/signal.c' || echo '$(srcdir)/'`intrinsics/signal.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/signal.Tpo" "$(DEPDIR)/signal.Plo"; else rm -f "$(DEPDIR)/signal.Tpo"; exit 1; fi diff --git a/libgfortran/acinclude.m4 b/libgfortran/acinclude.m4 index 44380615526..d1994b49d90 100644 --- a/libgfortran/acinclude.m4 +++ b/libgfortran/acinclude.m4 @@ -30,14 +30,14 @@ AC_DEFUN([AC_PROG_LD]) dnl Check whether the target supports hidden visibility. AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY], [ AC_CACHE_CHECK([whether the target supports hidden visibility], - have_attribute_visibility, [ + libgfor_cv_have_attribute_visibility, [ save_CFLAGS="$CFLAGS" CFLAGS="$CFLAGS -Werror" AC_TRY_COMPILE([void __attribute__((visibility("hidden"))) foo(void) { }], - [], have_attribute_visibility=yes, - have_attribute_visibility=no) + [], libgfor_cv_have_attribute_visibility=yes, + libgfor_cv_have_attribute_visibility=no) CFLAGS="$save_CFLAGS"]) - if test $have_attribute_visibility = yes; then + if test $libgfor_cv_have_attribute_visibility = yes; then AC_DEFINE(HAVE_ATTRIBUTE_VISIBILITY, 1, [Define to 1 if the target supports __attribute__((visibility(...))).]) fi]) @@ -45,14 +45,14 @@ AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY], [ dnl Check whether the target supports dllexport AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT], [ AC_CACHE_CHECK([whether the target supports dllexport], - have_attribute_dllexport, [ + libgfor_cv_have_attribute_dllexport, [ save_CFLAGS="$CFLAGS" CFLAGS="$CFLAGS -Werror" AC_TRY_COMPILE([void __attribute__((dllexport)) foo(void) { }], - [], have_attribute_dllexport=yes, - have_attribute_dllexport=no) + [], libgfor_cv_have_attribute_dllexport=yes, + libgfor_cv_have_attribute_dllexport=no) CFLAGS="$save_CFLAGS"]) - if test $have_attribute_dllexport = yes; then + if test $libgfor_cv_have_attribute_dllexport = yes; then AC_DEFINE(HAVE_ATTRIBUTE_DLLEXPORT, 1, [Define to 1 if the target supports __attribute__((dllexport)).]) fi]) @@ -60,12 +60,12 @@ AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT], [ dnl Check whether the target supports symbol aliases. AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_ALIAS], [ AC_CACHE_CHECK([whether the target supports symbol aliases], - have_attribute_alias, [ + libgfor_cv_have_attribute_alias, [ AC_TRY_LINK([ void foo(void) { } extern void bar(void) __attribute__((alias("foo")));], - [bar();], have_attribute_alias=yes, have_attribute_alias=no)]) - if test $have_attribute_alias = yes; then + [bar();], libgfor_cv_have_attribute_alias=yes, libgfor_cv_have_attribute_alias=no)]) + if test $libgfor_cv_have_attribute_alias = yes; then AC_DEFINE(HAVE_ATTRIBUTE_ALIAS, 1, [Define to 1 if the target supports __attribute__((alias(...))).]) fi]) @@ -73,12 +73,12 @@ extern void bar(void) __attribute__((alias("foo")));], dnl Check whether the target supports __sync_fetch_and_add. AC_DEFUN([LIBGFOR_CHECK_SYNC_FETCH_AND_ADD], [ AC_CACHE_CHECK([whether the target supports __sync_fetch_and_add], - have_sync_fetch_and_add, [ + libgfor_cv_have_sync_fetch_and_add, [ AC_TRY_LINK([int foovar = 0;], [ if (foovar <= 0) return __sync_fetch_and_add (&foovar, 1); if (foovar > 10) return __sync_add_and_fetch (&foovar, -1);], - have_sync_fetch_and_add=yes, have_sync_fetch_and_add=no)]) - if test $have_sync_fetch_and_add = yes; then + libgfor_cv_have_sync_fetch_and_add=yes, libgfor_cv_have_sync_fetch_and_add=no)]) + if test $libgfor_cv_have_sync_fetch_and_add = yes; then AC_DEFINE(HAVE_SYNC_FETCH_AND_ADD, 1, [Define to 1 if the target supports __sync_fetch_and_add]) fi]) @@ -97,13 +97,13 @@ target_thread_file=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'`]) dnl Check for pragma weak. AC_DEFUN([LIBGFOR_GTHREAD_WEAK], [ AC_CACHE_CHECK([whether pragma weak works], - have_pragma_weak, [ + libgfor_cv_have_pragma_weak, [ gfor_save_CFLAGS="$CFLAGS" CFLAGS="$CFLAGS -Wunknown-pragmas" AC_TRY_COMPILE([void foo (void); #pragma weak foo], [if (foo) foo ();], - have_pragma_weak=yes, have_pragma_weak=no)]) - if test $have_pragma_weak = yes; then + libgfor_cv_have_pragma_weak=yes, libgfor_cv_have_pragma_weak=no)]) + if test $libgfor_cv_have_pragma_weak = yes; then AC_DEFINE(SUPPORTS_WEAK, 1, [Define to 1 if the target supports #pragma weak]) fi @@ -117,7 +117,7 @@ AC_DEFUN([LIBGFOR_GTHREAD_WEAK], [ dnl Check whether target can unlink a file still open. AC_DEFUN([LIBGFOR_CHECK_UNLINK_OPEN_FILE], [ AC_CACHE_CHECK([whether the target can unlink an open file], - have_unlink_open_file, [ + libgfor_cv_have_unlink_open_file, [ AC_TRY_RUN([ #include <errno.h> #include <fcntl.h> @@ -140,19 +140,19 @@ int main () return 0; else return 1; -}], have_unlink_open_file=yes, have_unlink_open_file=no, [ +}], libgfor_cv_have_unlink_open_file=yes, libgfor_cv_have_unlink_open_file=no, [ case "${target}" in - *mingw*) have_unlink_open_file=no ;; - *) have_unlink_open_file=yes;; + *mingw*) libgfor_cv_have_unlink_open_file=no ;; + *) libgfor_cv_have_unlink_open_file=yes;; esac])]) -if test x"$have_unlink_open_file" = xyes; then +if test x"$libgfor_cv_have_unlink_open_file" = xyes; then AC_DEFINE(HAVE_UNLINK_OPEN_FILE, 1, [Define if target can unlink open files.]) fi]) dnl Check whether CRLF is the line terminator AC_DEFUN([LIBGFOR_CHECK_CRLF], [ AC_CACHE_CHECK([whether the target has CRLF as line terminator], - have_crlf, [ + libgfor_cv_have_crlf, [ AC_TRY_RUN([ /* This test program should exit with status 0 if system uses a CRLF as line terminator, and status 1 otherwise. @@ -187,12 +187,12 @@ int main () else exit(1); #endif -}], have_crlf=yes, have_crlf=no, [ +}], libgfor_cv_have_crlf=yes, libgfor_cv_have_crlf=no, [ case "${target}" in - *mingw*) have_crlf=yes ;; - *) have_crlf=no;; + *mingw*) libgfor_cv_have_crlf=yes ;; + *) libgfor_cv_have_crlf=no;; esac])]) -if test x"$have_crlf" = xyes; then +if test x"$libgfor_cv_have_crlf" = xyes; then AC_DEFINE(HAVE_CRLF, 1, [Define if CRLF is line terminator.]) fi]) @@ -200,7 +200,7 @@ dnl Check whether isfinite is broken. dnl The most common problem is that it does not work on long doubles. AC_DEFUN([LIBGFOR_CHECK_FOR_BROKEN_ISFINITE], [ AC_CACHE_CHECK([whether isfinite is broken], - have_broken_isfinite, [ + libgfor_cv_have_broken_isfinite, [ libgfor_check_for_broken_isfinite_save_LIBS=$LIBS LIBS="$LIBS -lm" AC_TRY_RUN([ @@ -217,13 +217,13 @@ int main () #endif #endif return 0; -}], have_broken_isfinite=no, have_broken_isfinite=yes, [ +}], libgfor_cv_have_broken_isfinite=no, libgfor_cv_have_broken_isfinite=yes, [ case "${target}" in - hppa*-*-hpux*) have_broken_isfinite=yes ;; - *) have_broken_isfinite=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_isfinite=yes ;; + *) libgfor_cv_have_broken_isfinite=no ;; esac])] LIBS=$libgfor_check_for_broken_isfinite_save_LIBS) -if test x"$have_broken_isfinite" = xyes; then +if test x"$libgfor_cv_have_broken_isfinite" = xyes; then AC_DEFINE(HAVE_BROKEN_ISFINITE, 1, [Define if isfinite is broken.]) fi]) @@ -231,7 +231,7 @@ dnl Check whether isnan is broken. dnl The most common problem is that it does not work on long doubles. AC_DEFUN([LIBGFOR_CHECK_FOR_BROKEN_ISNAN], [ AC_CACHE_CHECK([whether isnan is broken], - have_broken_isnan, [ + libgfor_cv_have_broken_isnan, [ libgfor_check_for_broken_isnan_save_LIBS=$LIBS LIBS="$LIBS -lm" AC_TRY_RUN([ @@ -266,13 +266,13 @@ int main () #endif #endif return 0; -}], have_broken_isnan=no, have_broken_isnan=yes, [ +}], libgfor_cv_have_broken_isnan=no, libgfor_cv_have_broken_isnan=yes, [ case "${target}" in - hppa*-*-hpux*) have_broken_isnan=yes ;; - *) have_broken_isnan=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_isnan=yes ;; + *) libgfor_cv_have_broken_isnan=no ;; esac])] LIBS=$libgfor_check_for_broken_isnan_save_LIBS) -if test x"$have_broken_isnan" = xyes; then +if test x"$libgfor_cv_have_broken_isnan" = xyes; then AC_DEFINE(HAVE_BROKEN_ISNAN, 1, [Define if isnan is broken.]) fi]) @@ -280,7 +280,7 @@ dnl Check whether fpclassify is broken. dnl The most common problem is that it does not work on long doubles. AC_DEFUN([LIBGFOR_CHECK_FOR_BROKEN_FPCLASSIFY], [ AC_CACHE_CHECK([whether fpclassify is broken], - have_broken_fpclassify, [ + libgfor_cv_have_broken_fpclassify, [ libgfor_check_for_broken_fpclassify_save_LIBS=$LIBS LIBS="$LIBS -lm" AC_TRY_RUN([ @@ -299,13 +299,13 @@ int main () #endif #endif return 0; -}], have_broken_fpclassify=no, have_broken_fpclassify=yes, [ +}], libgfor_cv_have_broken_fpclassify=no, libgfor_cv_have_broken_fpclassify=yes, [ case "${target}" in - hppa*-*-hpux*) have_broken_fpclassify=yes ;; - *) have_broken_fpclassify=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_fpclassify=yes ;; + *) libgfor_cv_have_broken_fpclassify=no ;; esac])] LIBS=$libgfor_check_for_broken_fpclassify_save_LIBS) -if test x"$have_broken_fpclassify" = xyes; then +if test x"$libgfor_cv_have_broken_fpclassify" = xyes; then AC_DEFINE(HAVE_BROKEN_FPCLASSIFY, 1, [Define if fpclassify is broken.]) fi]) @@ -314,7 +314,7 @@ dnl identify the file within the system. This is should be true for POSIX dnl systems; it is known to be false on mingw32. AC_DEFUN([LIBGFOR_CHECK_WORKING_STAT], [ AC_CACHE_CHECK([whether the target stat is reliable], - have_working_stat, [ + libgfor_cv_have_working_stat, [ AC_TRY_RUN([ #include <stdio.h> #include <sys/types.h> @@ -335,18 +335,18 @@ int main () fclose(f); fclose(g); return 0; -}], have_working_stat=yes, have_working_stat=no, [ +}], libgfor_cv_have_working_stat=yes, libgfor_cv_have_working_stat=no, [ case "${target}" in - *mingw*) have_working_stat=no ;; - *) have_working_stat=yes;; + *mingw*) libgfor_cv_have_working_stat=no ;; + *) libgfor_cv_have_working_stat=yes;; esac])]) -if test x"$have_working_stat" = xyes; then +if test x"$libgfor_cv_have_working_stat" = xyes; then AC_DEFINE(HAVE_WORKING_STAT, 1, [Define if target has a reliable stat.]) fi]) dnl Checks for fpsetmask function. AC_DEFUN([LIBGFOR_CHECK_FPSETMASK], [ - AC_CACHE_CHECK([whether fpsetmask is present], have_fpsetmask, [ + AC_CACHE_CHECK([whether fpsetmask is present], libgfor_cv_have_fpsetmask, [ AC_TRY_LINK([ #if HAVE_FLOATINGPOINT_H # include <floatingpoint.h> @@ -354,25 +354,25 @@ AC_DEFUN([LIBGFOR_CHECK_FPSETMASK], [ #if HAVE_IEEEFP_H # include <ieeefp.h> #endif /* HAVE_IEEEFP_H */],[fpsetmask(0);], - eval "have_fpsetmask=yes", eval "have_fpsetmask=no") + eval "libgfor_cv_have_fpsetmask=yes", eval "libgfor_cv_have_fpsetmask=no") ]) - if test x"$have_fpsetmask" = xyes; then + if test x"$libgfor_cv_have_fpsetmask" = xyes; then AC_DEFINE(HAVE_FPSETMASK, 1, [Define if you have fpsetmask.]) fi ]) dnl Check whether we have a mingw that provides a __mingw_snprintf function AC_DEFUN([LIBGFOR_CHECK_MINGW_SNPRINTF], [ - AC_CACHE_CHECK([whether __mingw_snprintf is present], have_mingw_snprintf, [ + AC_CACHE_CHECK([whether __mingw_snprintf is present], libgfor_cv_have_mingw_snprintf, [ AC_TRY_LINK([ #include <stdio.h> extern int __mingw_snprintf (char *, size_t, const char *, ...); ],[ __mingw_snprintf (NULL, 0, "%d\n", 1); ], - eval "have_mingw_snprintf=yes", eval "have_mingw_snprintf=no") + eval "libgfor_cv_have_mingw_snprintf=yes", eval "libgfor_cv_have_mingw_snprintf=no") ]) - if test x"$have_mingw_snprintf" = xyes; then + if test x"$libgfor_cv_have_mingw_snprintf" = xyes; then AC_DEFINE(HAVE_MINGW_SNPRINTF, 1, [Define if you have __mingw_snprintf.]) fi ]) diff --git a/libgfortran/configure b/libgfortran/configure index 8018012daca..ce4475df218 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -32036,7 +32036,7 @@ fi echo "$as_me:$LINENO: checking whether isfinite is broken" >&5 echo $ECHO_N "checking whether isfinite is broken... $ECHO_C" >&6 -if test "${have_broken_isfinite+set}" = set; then +if test "${libgfor_cv_have_broken_isfinite+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32045,8 +32045,8 @@ else if test "$cross_compiling" = yes; then case "${target}" in - hppa*-*-hpux*) have_broken_isfinite=yes ;; - *) have_broken_isfinite=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_isfinite=yes ;; + *) libgfor_cv_have_broken_isfinite=no ;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -32084,22 +32084,22 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_broken_isfinite=no + libgfor_cv_have_broken_isfinite=no else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_broken_isfinite=yes +libgfor_cv_have_broken_isfinite=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi LIBS=$libgfor_check_for_broken_isfinite_save_LIBS fi -echo "$as_me:$LINENO: result: $have_broken_isfinite" >&5 -echo "${ECHO_T}$have_broken_isfinite" >&6 -if test x"$have_broken_isfinite" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_broken_isfinite" >&5 +echo "${ECHO_T}$libgfor_cv_have_broken_isfinite" >&6 +if test x"$libgfor_cv_have_broken_isfinite" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_BROKEN_ISFINITE 1 @@ -32111,7 +32111,7 @@ fi echo "$as_me:$LINENO: checking whether isnan is broken" >&5 echo $ECHO_N "checking whether isnan is broken... $ECHO_C" >&6 -if test "${have_broken_isnan+set}" = set; then +if test "${libgfor_cv_have_broken_isnan+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32120,8 +32120,8 @@ else if test "$cross_compiling" = yes; then case "${target}" in - hppa*-*-hpux*) have_broken_isnan=yes ;; - *) have_broken_isnan=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_isnan=yes ;; + *) libgfor_cv_have_broken_isnan=no ;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -32177,22 +32177,22 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_broken_isnan=no + libgfor_cv_have_broken_isnan=no else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_broken_isnan=yes +libgfor_cv_have_broken_isnan=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi LIBS=$libgfor_check_for_broken_isnan_save_LIBS fi -echo "$as_me:$LINENO: result: $have_broken_isnan" >&5 -echo "${ECHO_T}$have_broken_isnan" >&6 -if test x"$have_broken_isnan" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_broken_isnan" >&5 +echo "${ECHO_T}$libgfor_cv_have_broken_isnan" >&6 +if test x"$libgfor_cv_have_broken_isnan" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_BROKEN_ISNAN 1 @@ -32204,7 +32204,7 @@ fi echo "$as_me:$LINENO: checking whether fpclassify is broken" >&5 echo $ECHO_N "checking whether fpclassify is broken... $ECHO_C" >&6 -if test "${have_broken_fpclassify+set}" = set; then +if test "${libgfor_cv_have_broken_fpclassify+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32213,8 +32213,8 @@ else if test "$cross_compiling" = yes; then case "${target}" in - hppa*-*-hpux*) have_broken_fpclassify=yes ;; - *) have_broken_fpclassify=no ;; + hppa*-*-hpux*) libgfor_cv_have_broken_fpclassify=yes ;; + *) libgfor_cv_have_broken_fpclassify=no ;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -32254,22 +32254,22 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_broken_fpclassify=no + libgfor_cv_have_broken_fpclassify=no else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_broken_fpclassify=yes +libgfor_cv_have_broken_fpclassify=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi LIBS=$libgfor_check_for_broken_fpclassify_save_LIBS fi -echo "$as_me:$LINENO: result: $have_broken_fpclassify" >&5 -echo "${ECHO_T}$have_broken_fpclassify" >&6 -if test x"$have_broken_fpclassify" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_broken_fpclassify" >&5 +echo "${ECHO_T}$libgfor_cv_have_broken_fpclassify" >&6 +if test x"$libgfor_cv_have_broken_fpclassify" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_BROKEN_FPCLASSIFY 1 @@ -32281,15 +32281,15 @@ fi echo "$as_me:$LINENO: checking whether the target stat is reliable" >&5 echo $ECHO_N "checking whether the target stat is reliable... $ECHO_C" >&6 -if test "${have_working_stat+set}" = set; then +if test "${libgfor_cv_have_working_stat+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then case "${target}" in - *mingw*) have_working_stat=no ;; - *) have_working_stat=yes;; + *mingw*) libgfor_cv_have_working_stat=no ;; + *) libgfor_cv_have_working_stat=yes;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -32331,21 +32331,21 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_working_stat=yes + libgfor_cv_have_working_stat=yes else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_working_stat=no +libgfor_cv_have_working_stat=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi -echo "$as_me:$LINENO: result: $have_working_stat" >&5 -echo "${ECHO_T}$have_working_stat" >&6 -if test x"$have_working_stat" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_working_stat" >&5 +echo "${ECHO_T}$libgfor_cv_have_working_stat" >&6 +if test x"$libgfor_cv_have_working_stat" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_WORKING_STAT 1 @@ -32357,7 +32357,7 @@ fi echo "$as_me:$LINENO: checking whether __mingw_snprintf is present" >&5 echo $ECHO_N "checking whether __mingw_snprintf is present... $ECHO_C" >&6 -if test "${have_mingw_snprintf+set}" = set; then +if test "${libgfor_cv_have_mingw_snprintf+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32408,20 +32408,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - eval "have_mingw_snprintf=yes" + eval "libgfor_cv_have_mingw_snprintf=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -eval "have_mingw_snprintf=no" +eval "libgfor_cv_have_mingw_snprintf=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi -echo "$as_me:$LINENO: result: $have_mingw_snprintf" >&5 -echo "${ECHO_T}$have_mingw_snprintf" >&6 - if test x"$have_mingw_snprintf" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_mingw_snprintf" >&5 +echo "${ECHO_T}$libgfor_cv_have_mingw_snprintf" >&6 + if test x"$libgfor_cv_have_mingw_snprintf" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_MINGW_SNPRINTF 1 @@ -32513,7 +32513,7 @@ fi echo "$as_me:$LINENO: checking whether fpsetmask is present" >&5 echo $ECHO_N "checking whether fpsetmask is present... $ECHO_C" >&6 -if test "${have_fpsetmask+set}" = set; then +if test "${libgfor_cv_have_fpsetmask+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32565,20 +32565,20 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - eval "have_fpsetmask=yes" + eval "libgfor_cv_have_fpsetmask=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -eval "have_fpsetmask=no" +eval "libgfor_cv_have_fpsetmask=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi -echo "$as_me:$LINENO: result: $have_fpsetmask" >&5 -echo "${ECHO_T}$have_fpsetmask" >&6 - if test x"$have_fpsetmask" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_fpsetmask" >&5 +echo "${ECHO_T}$libgfor_cv_have_fpsetmask" >&6 + if test x"$libgfor_cv_have_fpsetmask" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_FPSETMASK 1 @@ -32808,7 +32808,7 @@ FPU_HOST_HEADER=config/${fpu_host}.h echo "$as_me:$LINENO: checking whether the target supports hidden visibility" >&5 echo $ECHO_N "checking whether the target supports hidden visibility... $ECHO_C" >&6 -if test "${have_attribute_visibility+set}" = set; then +if test "${libgfor_cv_have_attribute_visibility+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32851,19 +32851,19 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_attribute_visibility=yes + libgfor_cv_have_attribute_visibility=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_attribute_visibility=no +libgfor_cv_have_attribute_visibility=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$save_CFLAGS" fi -echo "$as_me:$LINENO: result: $have_attribute_visibility" >&5 -echo "${ECHO_T}$have_attribute_visibility" >&6 - if test $have_attribute_visibility = yes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_attribute_visibility" >&5 +echo "${ECHO_T}$libgfor_cv_have_attribute_visibility" >&6 + if test $libgfor_cv_have_attribute_visibility = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_ATTRIBUTE_VISIBILITY 1 @@ -32873,7 +32873,7 @@ _ACEOF echo "$as_me:$LINENO: checking whether the target supports dllexport" >&5 echo $ECHO_N "checking whether the target supports dllexport... $ECHO_C" >&6 -if test "${have_attribute_dllexport+set}" = set; then +if test "${libgfor_cv_have_attribute_dllexport+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32916,19 +32916,19 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_attribute_dllexport=yes + libgfor_cv_have_attribute_dllexport=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_attribute_dllexport=no +libgfor_cv_have_attribute_dllexport=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$save_CFLAGS" fi -echo "$as_me:$LINENO: result: $have_attribute_dllexport" >&5 -echo "${ECHO_T}$have_attribute_dllexport" >&6 - if test $have_attribute_dllexport = yes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_attribute_dllexport" >&5 +echo "${ECHO_T}$libgfor_cv_have_attribute_dllexport" >&6 + if test $libgfor_cv_have_attribute_dllexport = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_ATTRIBUTE_DLLEXPORT 1 @@ -32938,7 +32938,7 @@ _ACEOF echo "$as_me:$LINENO: checking whether the target supports symbol aliases" >&5 echo $ECHO_N "checking whether the target supports symbol aliases... $ECHO_C" >&6 -if test "${have_attribute_alias+set}" = set; then +if test "${libgfor_cv_have_attribute_alias+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -32986,19 +32986,19 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_attribute_alias=yes + libgfor_cv_have_attribute_alias=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_attribute_alias=no +libgfor_cv_have_attribute_alias=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi -echo "$as_me:$LINENO: result: $have_attribute_alias" >&5 -echo "${ECHO_T}$have_attribute_alias" >&6 - if test $have_attribute_alias = yes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_attribute_alias" >&5 +echo "${ECHO_T}$libgfor_cv_have_attribute_alias" >&6 + if test $libgfor_cv_have_attribute_alias = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_ATTRIBUTE_ALIAS 1 @@ -33010,7 +33010,7 @@ _ACEOF echo "$as_me:$LINENO: checking whether the target supports __sync_fetch_and_add" >&5 echo $ECHO_N "checking whether the target supports __sync_fetch_and_add... $ECHO_C" >&6 -if test "${have_sync_fetch_and_add+set}" = set; then +if test "${libgfor_cv_have_sync_fetch_and_add+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -33058,19 +33058,19 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_sync_fetch_and_add=yes + libgfor_cv_have_sync_fetch_and_add=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_sync_fetch_and_add=no +libgfor_cv_have_sync_fetch_and_add=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi -echo "$as_me:$LINENO: result: $have_sync_fetch_and_add" >&5 -echo "${ECHO_T}$have_sync_fetch_and_add" >&6 - if test $have_sync_fetch_and_add = yes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_sync_fetch_and_add" >&5 +echo "${ECHO_T}$libgfor_cv_have_sync_fetch_and_add" >&6 + if test $libgfor_cv_have_sync_fetch_and_add = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_SYNC_FETCH_AND_ADD 1 @@ -33103,7 +33103,7 @@ _ACEOF echo "$as_me:$LINENO: checking whether pragma weak works" >&5 echo $ECHO_N "checking whether pragma weak works... $ECHO_C" >&6 -if test "${have_pragma_weak+set}" = set; then +if test "${libgfor_cv_have_pragma_weak+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -33147,18 +33147,18 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_pragma_weak=yes + libgfor_cv_have_pragma_weak=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -have_pragma_weak=no +libgfor_cv_have_pragma_weak=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -echo "$as_me:$LINENO: result: $have_pragma_weak" >&5 -echo "${ECHO_T}$have_pragma_weak" >&6 - if test $have_pragma_weak = yes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_pragma_weak" >&5 +echo "${ECHO_T}$libgfor_cv_have_pragma_weak" >&6 + if test $libgfor_cv_have_pragma_weak = yes; then cat >>confdefs.h <<\_ACEOF #define SUPPORTS_WEAK 1 @@ -33179,15 +33179,15 @@ _ACEOF echo "$as_me:$LINENO: checking whether the target can unlink an open file" >&5 echo $ECHO_N "checking whether the target can unlink an open file... $ECHO_C" >&6 -if test "${have_unlink_open_file+set}" = set; then +if test "${libgfor_cv_have_unlink_open_file+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then case "${target}" in - *mingw*) have_unlink_open_file=no ;; - *) have_unlink_open_file=yes;; + *mingw*) libgfor_cv_have_unlink_open_file=no ;; + *) libgfor_cv_have_unlink_open_file=yes;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -33231,21 +33231,21 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_unlink_open_file=yes + libgfor_cv_have_unlink_open_file=yes else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_unlink_open_file=no +libgfor_cv_have_unlink_open_file=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi -echo "$as_me:$LINENO: result: $have_unlink_open_file" >&5 -echo "${ECHO_T}$have_unlink_open_file" >&6 -if test x"$have_unlink_open_file" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_unlink_open_file" >&5 +echo "${ECHO_T}$libgfor_cv_have_unlink_open_file" >&6 +if test x"$libgfor_cv_have_unlink_open_file" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_UNLINK_OPEN_FILE 1 @@ -33257,15 +33257,15 @@ fi echo "$as_me:$LINENO: checking whether the target has CRLF as line terminator" >&5 echo $ECHO_N "checking whether the target has CRLF as line terminator... $ECHO_C" >&6 -if test "${have_crlf+set}" = set; then +if test "${libgfor_cv_have_crlf+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then case "${target}" in - *mingw*) have_crlf=yes ;; - *) have_crlf=no;; + *mingw*) libgfor_cv_have_crlf=yes ;; + *) libgfor_cv_have_crlf=no;; esac else cat >conftest.$ac_ext <<_ACEOF @@ -33321,21 +33321,21 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - have_crlf=yes + libgfor_cv_have_crlf=yes else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -have_crlf=no +libgfor_cv_have_crlf=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi -echo "$as_me:$LINENO: result: $have_crlf" >&5 -echo "${ECHO_T}$have_crlf" >&6 -if test x"$have_crlf" = xyes; then +echo "$as_me:$LINENO: result: $libgfor_cv_have_crlf" >&5 +echo "${ECHO_T}$libgfor_cv_have_crlf" >&6 +if test x"$libgfor_cv_have_crlf" = xyes; then cat >>confdefs.h <<\_ACEOF #define HAVE_CRLF 1 diff --git a/libgfortran/generated/all_l1.c b/libgfortran/generated/all_l1.c index 385726af399..8345adc1f6e 100644 --- a/libgfortran/generated/all_l1.c +++ b/libgfortran/generated/all_l1.c @@ -57,6 +57,7 @@ all_l1 (gfc_array_l1 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ all_l1 (gfc_array_l1 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ all_l1 (gfc_array_l1 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_1 result; @@ -207,7 +212,7 @@ all_l1 (gfc_array_l1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/all_l16.c b/libgfortran/generated/all_l16.c index fd6a9f0b715..ee6f8f93c9f 100644 --- a/libgfortran/generated/all_l16.c +++ b/libgfortran/generated/all_l16.c @@ -57,6 +57,7 @@ all_l16 (gfc_array_l16 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ all_l16 (gfc_array_l16 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ all_l16 (gfc_array_l16 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; @@ -207,7 +212,7 @@ all_l16 (gfc_array_l16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/all_l2.c b/libgfortran/generated/all_l2.c index 16b4ec94ea1..dd069c57d61 100644 --- a/libgfortran/generated/all_l2.c +++ b/libgfortran/generated/all_l2.c @@ -57,6 +57,7 @@ all_l2 (gfc_array_l2 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ all_l2 (gfc_array_l2 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ all_l2 (gfc_array_l2 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_2 result; @@ -207,7 +212,7 @@ all_l2 (gfc_array_l2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/all_l4.c b/libgfortran/generated/all_l4.c index ef8bdcdddba..00a0896f669 100644 --- a/libgfortran/generated/all_l4.c +++ b/libgfortran/generated/all_l4.c @@ -57,6 +57,7 @@ all_l4 (gfc_array_l4 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ all_l4 (gfc_array_l4 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ all_l4 (gfc_array_l4 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; @@ -207,7 +212,7 @@ all_l4 (gfc_array_l4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/all_l8.c b/libgfortran/generated/all_l8.c index 8e7a659a283..b08c19cdba5 100644 --- a/libgfortran/generated/all_l8.c +++ b/libgfortran/generated/all_l8.c @@ -57,6 +57,7 @@ all_l8 (gfc_array_l8 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ all_l8 (gfc_array_l8 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ all_l8 (gfc_array_l8 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; @@ -207,7 +212,7 @@ all_l8 (gfc_array_l8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/any_l1.c b/libgfortran/generated/any_l1.c index 8975438ae59..2d11eb1a3b4 100644 --- a/libgfortran/generated/any_l1.c +++ b/libgfortran/generated/any_l1.c @@ -57,6 +57,7 @@ any_l1 (gfc_array_l1 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ any_l1 (gfc_array_l1 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ any_l1 (gfc_array_l1 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_1 result; @@ -207,7 +212,7 @@ any_l1 (gfc_array_l1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/any_l16.c b/libgfortran/generated/any_l16.c index 060a4b82127..3d7cd1b1ef9 100644 --- a/libgfortran/generated/any_l16.c +++ b/libgfortran/generated/any_l16.c @@ -57,6 +57,7 @@ any_l16 (gfc_array_l16 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ any_l16 (gfc_array_l16 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ any_l16 (gfc_array_l16 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; @@ -207,7 +212,7 @@ any_l16 (gfc_array_l16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/any_l2.c b/libgfortran/generated/any_l2.c index 73db5aea082..1c874182b3e 100644 --- a/libgfortran/generated/any_l2.c +++ b/libgfortran/generated/any_l2.c @@ -57,6 +57,7 @@ any_l2 (gfc_array_l2 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ any_l2 (gfc_array_l2 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ any_l2 (gfc_array_l2 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_2 result; @@ -207,7 +212,7 @@ any_l2 (gfc_array_l2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/any_l4.c b/libgfortran/generated/any_l4.c index 3e239cab106..71a8cb0e63f 100644 --- a/libgfortran/generated/any_l4.c +++ b/libgfortran/generated/any_l4.c @@ -57,6 +57,7 @@ any_l4 (gfc_array_l4 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ any_l4 (gfc_array_l4 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ any_l4 (gfc_array_l4 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; @@ -207,7 +212,7 @@ any_l4 (gfc_array_l4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/any_l8.c b/libgfortran/generated/any_l8.c index 3ea80dd3e31..55ff7a601b0 100644 --- a/libgfortran/generated/any_l8.c +++ b/libgfortran/generated/any_l8.c @@ -57,6 +57,7 @@ any_l8 (gfc_array_l8 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ any_l8 (gfc_array_l8 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ any_l8 (gfc_array_l8 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; @@ -207,7 +212,7 @@ any_l8 (gfc_array_l8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/count_16_l.c b/libgfortran/generated/count_16_l.c index 654c5495dec..638fb179e25 100644 --- a/libgfortran/generated/count_16_l.c +++ b/libgfortran/generated/count_16_l.c @@ -57,6 +57,7 @@ count_16_l (gfc_array_i16 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ count_16_l (gfc_array_i16 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ count_16_l (gfc_array_i16 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_16 result; @@ -203,7 +208,7 @@ count_16_l (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/count_1_l.c b/libgfortran/generated/count_1_l.c index ab2d0eac21a..52ae34baa5f 100644 --- a/libgfortran/generated/count_1_l.c +++ b/libgfortran/generated/count_1_l.c @@ -57,6 +57,7 @@ count_1_l (gfc_array_i1 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ count_1_l (gfc_array_i1 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ count_1_l (gfc_array_i1 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_1 result; @@ -203,7 +208,7 @@ count_1_l (gfc_array_i1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/count_2_l.c b/libgfortran/generated/count_2_l.c index bb29d4f3c4f..ddede7160f5 100644 --- a/libgfortran/generated/count_2_l.c +++ b/libgfortran/generated/count_2_l.c @@ -57,6 +57,7 @@ count_2_l (gfc_array_i2 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ count_2_l (gfc_array_i2 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ count_2_l (gfc_array_i2 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_2 result; @@ -203,7 +208,7 @@ count_2_l (gfc_array_i2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/count_4_l.c b/libgfortran/generated/count_4_l.c index 82926bd522e..6bdc9ca18bf 100644 --- a/libgfortran/generated/count_4_l.c +++ b/libgfortran/generated/count_4_l.c @@ -57,6 +57,7 @@ count_4_l (gfc_array_i4 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ count_4_l (gfc_array_i4 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ count_4_l (gfc_array_i4 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_4 result; @@ -203,7 +208,7 @@ count_4_l (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/count_8_l.c b/libgfortran/generated/count_8_l.c index 9cb094f81cd..3c1c5653610 100644 --- a/libgfortran/generated/count_8_l.c +++ b/libgfortran/generated/count_8_l.c @@ -57,6 +57,7 @@ count_8_l (gfc_array_i8 * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -65,6 +66,9 @@ count_8_l (gfc_array_i8 * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -164,7 +168,8 @@ count_8_l (gfc_array_i8 * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_8 result; @@ -203,7 +208,7 @@ count_8_l (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/generated/matmul_c10.c b/libgfortran/generated/matmul_c10.c index 84c6c5daabb..08c2044dd8b 100644 --- a/libgfortran/generated/matmul_c10.c +++ b/libgfortran/generated/matmul_c10.c @@ -170,7 +170,10 @@ matmul_c10 (gfc_array_c10 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_c16.c b/libgfortran/generated/matmul_c16.c index 79ca57858ab..6a2a6390967 100644 --- a/libgfortran/generated/matmul_c16.c +++ b/libgfortran/generated/matmul_c16.c @@ -170,7 +170,10 @@ matmul_c16 (gfc_array_c16 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_c4.c b/libgfortran/generated/matmul_c4.c index f6b15796ad9..6dcf6fea56a 100644 --- a/libgfortran/generated/matmul_c4.c +++ b/libgfortran/generated/matmul_c4.c @@ -170,7 +170,10 @@ matmul_c4 (gfc_array_c4 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_c8.c b/libgfortran/generated/matmul_c8.c index 5f4bdec8670..8bc619d879f 100644 --- a/libgfortran/generated/matmul_c8.c +++ b/libgfortran/generated/matmul_c8.c @@ -170,7 +170,10 @@ matmul_c8 (gfc_array_c8 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_i1.c b/libgfortran/generated/matmul_i1.c index 7c2e95e8893..ca16ed40b2f 100644 --- a/libgfortran/generated/matmul_i1.c +++ b/libgfortran/generated/matmul_i1.c @@ -170,7 +170,10 @@ matmul_i1 (gfc_array_i1 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_i16.c b/libgfortran/generated/matmul_i16.c index 9c33cc77b82..33c62ae4152 100644 --- a/libgfortran/generated/matmul_i16.c +++ b/libgfortran/generated/matmul_i16.c @@ -170,7 +170,10 @@ matmul_i16 (gfc_array_i16 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_i2.c b/libgfortran/generated/matmul_i2.c index 143f7832941..e3119acbd41 100644 --- a/libgfortran/generated/matmul_i2.c +++ b/libgfortran/generated/matmul_i2.c @@ -170,7 +170,10 @@ matmul_i2 (gfc_array_i2 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_i4.c b/libgfortran/generated/matmul_i4.c index b90c43851f1..a1b8c50f051 100644 --- a/libgfortran/generated/matmul_i4.c +++ b/libgfortran/generated/matmul_i4.c @@ -170,7 +170,10 @@ matmul_i4 (gfc_array_i4 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_i8.c b/libgfortran/generated/matmul_i8.c index b3260757c6e..eee73ac88f0 100644 --- a/libgfortran/generated/matmul_i8.c +++ b/libgfortran/generated/matmul_i8.c @@ -170,7 +170,10 @@ matmul_i8 (gfc_array_i8 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_r10.c b/libgfortran/generated/matmul_r10.c index ee404b1b789..58dfe75814f 100644 --- a/libgfortran/generated/matmul_r10.c +++ b/libgfortran/generated/matmul_r10.c @@ -170,7 +170,10 @@ matmul_r10 (gfc_array_r10 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_r16.c b/libgfortran/generated/matmul_r16.c index 1d5f41efae5..a6a93be91fb 100644 --- a/libgfortran/generated/matmul_r16.c +++ b/libgfortran/generated/matmul_r16.c @@ -170,7 +170,10 @@ matmul_r16 (gfc_array_r16 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_r4.c b/libgfortran/generated/matmul_r4.c index dc89f5592f9..1154d41a33f 100644 --- a/libgfortran/generated/matmul_r4.c +++ b/libgfortran/generated/matmul_r4.c @@ -170,7 +170,10 @@ matmul_r4 (gfc_array_r4 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/matmul_r8.c b/libgfortran/generated/matmul_r8.c index 5b23f28d697..7bce2533b41 100644 --- a/libgfortran/generated/matmul_r8.c +++ b/libgfortran/generated/matmul_r8.c @@ -170,7 +170,10 @@ matmul_r8 (gfc_array_r8 * const restrict retarray, } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/generated/maxloc1_16_i1.c b/libgfortran/generated/maxloc1_16_i1.c index 47e67239322..7cccedae55b 100644 --- a/libgfortran/generated/maxloc1_16_i1.c +++ b/libgfortran/generated/maxloc1_16_i1.c @@ -57,12 +57,15 @@ maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_i16.c b/libgfortran/generated/maxloc1_16_i16.c index 2c8a06cb675..d7126afbcce 100644 --- a/libgfortran/generated/maxloc1_16_i16.c +++ b/libgfortran/generated/maxloc1_16_i16.c @@ -57,12 +57,15 @@ maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_i2.c b/libgfortran/generated/maxloc1_16_i2.c index d7b1ca57eed..278ef5b5eb9 100644 --- a/libgfortran/generated/maxloc1_16_i2.c +++ b/libgfortran/generated/maxloc1_16_i2.c @@ -57,12 +57,15 @@ maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_i4.c b/libgfortran/generated/maxloc1_16_i4.c index 394c0160261..4e2e73114d3 100644 --- a/libgfortran/generated/maxloc1_16_i4.c +++ b/libgfortran/generated/maxloc1_16_i4.c @@ -57,12 +57,15 @@ maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_i8.c b/libgfortran/generated/maxloc1_16_i8.c index 5cff65dece4..1a9eb519adb 100644 --- a/libgfortran/generated/maxloc1_16_i8.c +++ b/libgfortran/generated/maxloc1_16_i8.c @@ -57,12 +57,15 @@ maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_r10.c b/libgfortran/generated/maxloc1_16_r10.c index 32af8cd8854..79805f5519b 100644 --- a/libgfortran/generated/maxloc1_16_r10.c +++ b/libgfortran/generated/maxloc1_16_r10.c @@ -57,12 +57,15 @@ maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_r16.c b/libgfortran/generated/maxloc1_16_r16.c index d695ad8ec5d..49b27c34227 100644 --- a/libgfortran/generated/maxloc1_16_r16.c +++ b/libgfortran/generated/maxloc1_16_r16.c @@ -57,12 +57,15 @@ maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_r4.c b/libgfortran/generated/maxloc1_16_r4.c index 05dfbe380a7..cb4cc17f78c 100644 --- a/libgfortran/generated/maxloc1_16_r4.c +++ b/libgfortran/generated/maxloc1_16_r4.c @@ -57,12 +57,15 @@ maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_16_r8.c b/libgfortran/generated/maxloc1_16_r8.c index a060e0620a8..bddedbe63fa 100644 --- a/libgfortran/generated/maxloc1_16_r8.c +++ b/libgfortran/generated/maxloc1_16_r8.c @@ -57,12 +57,15 @@ maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxloc1_16_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_i1.c b/libgfortran/generated/maxloc1_4_i1.c index 2244456c154..3a1ae07de92 100644 --- a/libgfortran/generated/maxloc1_4_i1.c +++ b/libgfortran/generated/maxloc1_4_i1.c @@ -57,12 +57,15 @@ maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_i16.c b/libgfortran/generated/maxloc1_4_i16.c index d0f260c962d..d9e1b3e527f 100644 --- a/libgfortran/generated/maxloc1_4_i16.c +++ b/libgfortran/generated/maxloc1_4_i16.c @@ -57,12 +57,15 @@ maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_i2.c b/libgfortran/generated/maxloc1_4_i2.c index 5415ebabacf..dedb28b8dc0 100644 --- a/libgfortran/generated/maxloc1_4_i2.c +++ b/libgfortran/generated/maxloc1_4_i2.c @@ -57,12 +57,15 @@ maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_i4.c b/libgfortran/generated/maxloc1_4_i4.c index 291b919945d..12bad843e92 100644 --- a/libgfortran/generated/maxloc1_4_i4.c +++ b/libgfortran/generated/maxloc1_4_i4.c @@ -57,12 +57,15 @@ maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_i8.c b/libgfortran/generated/maxloc1_4_i8.c index 97a904dc687..2215521cb1b 100644 --- a/libgfortran/generated/maxloc1_4_i8.c +++ b/libgfortran/generated/maxloc1_4_i8.c @@ -57,12 +57,15 @@ maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_r10.c b/libgfortran/generated/maxloc1_4_r10.c index 07ccb242ae4..0ed1df2fde0 100644 --- a/libgfortran/generated/maxloc1_4_r10.c +++ b/libgfortran/generated/maxloc1_4_r10.c @@ -57,12 +57,15 @@ maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_r16.c b/libgfortran/generated/maxloc1_4_r16.c index 5ecfffd7b04..ae1a4f16fab 100644 --- a/libgfortran/generated/maxloc1_4_r16.c +++ b/libgfortran/generated/maxloc1_4_r16.c @@ -57,12 +57,15 @@ maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_r4.c b/libgfortran/generated/maxloc1_4_r4.c index f859cc76199..6b1656424cd 100644 --- a/libgfortran/generated/maxloc1_4_r4.c +++ b/libgfortran/generated/maxloc1_4_r4.c @@ -57,12 +57,15 @@ maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_4_r8.c b/libgfortran/generated/maxloc1_4_r8.c index 5d673420fd9..bbc6f9e54e5 100644 --- a/libgfortran/generated/maxloc1_4_r8.c +++ b/libgfortran/generated/maxloc1_4_r8.c @@ -57,12 +57,15 @@ maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxloc1_4_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_i1.c b/libgfortran/generated/maxloc1_8_i1.c index f9ea707ab95..85c44f9d0dc 100644 --- a/libgfortran/generated/maxloc1_8_i1.c +++ b/libgfortran/generated/maxloc1_8_i1.c @@ -57,12 +57,15 @@ maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_i16.c b/libgfortran/generated/maxloc1_8_i16.c index 478a8bc87b0..18d1ad1d2f2 100644 --- a/libgfortran/generated/maxloc1_8_i16.c +++ b/libgfortran/generated/maxloc1_8_i16.c @@ -57,12 +57,15 @@ maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_i2.c b/libgfortran/generated/maxloc1_8_i2.c index 972767f6558..121cc0fe8cb 100644 --- a/libgfortran/generated/maxloc1_8_i2.c +++ b/libgfortran/generated/maxloc1_8_i2.c @@ -57,12 +57,15 @@ maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_i4.c b/libgfortran/generated/maxloc1_8_i4.c index e3b566d57ec..8386a29979e 100644 --- a/libgfortran/generated/maxloc1_8_i4.c +++ b/libgfortran/generated/maxloc1_8_i4.c @@ -57,12 +57,15 @@ maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_i8.c b/libgfortran/generated/maxloc1_8_i8.c index e30e104dfc6..ed71c492502 100644 --- a/libgfortran/generated/maxloc1_8_i8.c +++ b/libgfortran/generated/maxloc1_8_i8.c @@ -57,12 +57,15 @@ maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_r10.c b/libgfortran/generated/maxloc1_8_r10.c index 01e30f660e4..a7b71bc54f3 100644 --- a/libgfortran/generated/maxloc1_8_r10.c +++ b/libgfortran/generated/maxloc1_8_r10.c @@ -57,12 +57,15 @@ maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_r16.c b/libgfortran/generated/maxloc1_8_r16.c index fbe72d1874f..9fd0b46dbda 100644 --- a/libgfortran/generated/maxloc1_8_r16.c +++ b/libgfortran/generated/maxloc1_8_r16.c @@ -57,12 +57,15 @@ maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_r4.c b/libgfortran/generated/maxloc1_8_r4.c index 3985d684fe4..79f1103dc8f 100644 --- a/libgfortran/generated/maxloc1_8_r4.c +++ b/libgfortran/generated/maxloc1_8_r4.c @@ -57,12 +57,15 @@ maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/maxloc1_8_r8.c b/libgfortran/generated/maxloc1_8_r8.c index 6e7745b31ba..b0ab7608b41 100644 --- a/libgfortran/generated/maxloc1_8_r8.c +++ b/libgfortran/generated/maxloc1_8_r8.c @@ -57,12 +57,15 @@ maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ smaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxloc1_8_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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_i1.c b/libgfortran/generated/maxval_i1.c index 901f4e7f2a7..a7288eb827b 100644 --- a/libgfortran/generated/maxval_i1.c +++ b/libgfortran/generated/maxval_i1.c @@ -56,12 +56,15 @@ maxval_i1 (gfc_array_i1 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_i1 (gfc_array_i1 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_1 result; @@ -187,8 +191,8 @@ maxval_i1 (gfc_array_i1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_i1 (gfc_array_i1 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_1 *dest; + index_type dim; + if (*mask) { maxval_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = (-GFC_INTEGER_1_HUGE-1) ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_1_HUGE-1); + 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_i16.c b/libgfortran/generated/maxval_i16.c index c082e856922..d50ab6f3558 100644 --- a/libgfortran/generated/maxval_i16.c +++ b/libgfortran/generated/maxval_i16.c @@ -56,12 +56,15 @@ maxval_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -187,8 +191,8 @@ maxval_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { maxval_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = (-GFC_INTEGER_16_HUGE-1) ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_16_HUGE-1); + 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_i2.c b/libgfortran/generated/maxval_i2.c index 87865e1b49b..c49b1812043 100644 --- a/libgfortran/generated/maxval_i2.c +++ b/libgfortran/generated/maxval_i2.c @@ -56,12 +56,15 @@ maxval_i2 (gfc_array_i2 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_i2 (gfc_array_i2 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_2 result; @@ -187,8 +191,8 @@ maxval_i2 (gfc_array_i2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_i2 (gfc_array_i2 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_2 *dest; + index_type dim; + if (*mask) { maxval_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = (-GFC_INTEGER_2_HUGE-1) ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_2_HUGE-1); + 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_i4.c b/libgfortran/generated/maxval_i4.c index 3fa4a10b1bf..354c86d9a1e 100644 --- a/libgfortran/generated/maxval_i4.c +++ b/libgfortran/generated/maxval_i4.c @@ -56,12 +56,15 @@ maxval_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -187,8 +191,8 @@ maxval_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { maxval_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = (-GFC_INTEGER_4_HUGE-1) ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_4_HUGE-1); + 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_i8.c b/libgfortran/generated/maxval_i8.c index 8b2106d209f..91a2b00c619 100644 --- a/libgfortran/generated/maxval_i8.c +++ b/libgfortran/generated/maxval_i8.c @@ -56,12 +56,15 @@ maxval_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -187,8 +191,8 @@ maxval_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { maxval_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = (-GFC_INTEGER_8_HUGE-1) ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_8_HUGE-1); + 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_r10.c b/libgfortran/generated/maxval_r10.c index a076190e8af..c959a8083a6 100644 --- a/libgfortran/generated/maxval_r10.c +++ b/libgfortran/generated/maxval_r10.c @@ -56,12 +56,15 @@ maxval_r10 (gfc_array_r10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_r10 (gfc_array_r10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_REAL_10 result; @@ -187,8 +191,8 @@ maxval_r10 (gfc_array_r10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_r10 (gfc_array_r10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_10 *dest; + index_type dim; + if (*mask) { maxval_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = -GFC_REAL_10_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_10_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_r16.c b/libgfortran/generated/maxval_r16.c index 1e36379048b..a05808d2e5c 100644 --- a/libgfortran/generated/maxval_r16.c +++ b/libgfortran/generated/maxval_r16.c @@ -56,12 +56,15 @@ maxval_r16 (gfc_array_r16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_r16 (gfc_array_r16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_REAL_16 result; @@ -187,8 +191,8 @@ maxval_r16 (gfc_array_r16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_r16 (gfc_array_r16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_16 *dest; + index_type dim; + if (*mask) { maxval_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = -GFC_REAL_16_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_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_r4.c b/libgfortran/generated/maxval_r4.c index 222a4e3beee..a00468bc845 100644 --- a/libgfortran/generated/maxval_r4.c +++ b/libgfortran/generated/maxval_r4.c @@ -56,12 +56,15 @@ maxval_r4 (gfc_array_r4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_r4 (gfc_array_r4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_REAL_4 result; @@ -187,8 +191,8 @@ maxval_r4 (gfc_array_r4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_r4 (gfc_array_r4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_4 *dest; + index_type dim; + if (*mask) { maxval_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = -GFC_REAL_4_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_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_r8.c b/libgfortran/generated/maxval_r8.c index 163ec5a1b03..1c9e41df6d0 100644 --- a/libgfortran/generated/maxval_r8.c +++ b/libgfortran/generated/maxval_r8.c @@ -56,12 +56,15 @@ maxval_r8 (gfc_array_r8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ maxval_r8 (gfc_array_r8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_REAL_8 result; @@ -187,8 +191,8 @@ maxval_r8 (gfc_array_r8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ smaxval_r8 (gfc_array_r8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_8 *dest; + index_type dim; + if (*mask) { maxval_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MAXVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = -GFC_REAL_8_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_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/minloc1_16_i1.c b/libgfortran/generated/minloc1_16_i1.c index f4abfa8f0d1..f95aa906897 100644 --- a/libgfortran/generated/minloc1_16_i1.c +++ b/libgfortran/generated/minloc1_16_i1.c @@ -57,12 +57,15 @@ minloc1_16_i1 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_i1 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_i1 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_i1 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_i16.c b/libgfortran/generated/minloc1_16_i16.c index 40b86eadc6c..9a5da308ede 100644 --- a/libgfortran/generated/minloc1_16_i16.c +++ b/libgfortran/generated/minloc1_16_i16.c @@ -57,12 +57,15 @@ minloc1_16_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_i2.c b/libgfortran/generated/minloc1_16_i2.c index f7057b2c849..ad282f9b774 100644 --- a/libgfortran/generated/minloc1_16_i2.c +++ b/libgfortran/generated/minloc1_16_i2.c @@ -57,12 +57,15 @@ minloc1_16_i2 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_i2 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_i2 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_i2 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_i4.c b/libgfortran/generated/minloc1_16_i4.c index 3cf6f0de83f..7eb382d89ee 100644 --- a/libgfortran/generated/minloc1_16_i4.c +++ b/libgfortran/generated/minloc1_16_i4.c @@ -57,12 +57,15 @@ minloc1_16_i4 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_i4 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_i4 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_i4 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_i8.c b/libgfortran/generated/minloc1_16_i8.c index a0838687ba8..7995d26101c 100644 --- a/libgfortran/generated/minloc1_16_i8.c +++ b/libgfortran/generated/minloc1_16_i8.c @@ -57,12 +57,15 @@ minloc1_16_i8 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_i8 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_i8 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_i8 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_r10.c b/libgfortran/generated/minloc1_16_r10.c index 20b1c5789a7..c7da9d1b5dc 100644 --- a/libgfortran/generated/minloc1_16_r10.c +++ b/libgfortran/generated/minloc1_16_r10.c @@ -57,12 +57,15 @@ minloc1_16_r10 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_r10 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_r10 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_r10 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_r16.c b/libgfortran/generated/minloc1_16_r16.c index 40fcbaea3f9..c24cb81dca5 100644 --- a/libgfortran/generated/minloc1_16_r16.c +++ b/libgfortran/generated/minloc1_16_r16.c @@ -57,12 +57,15 @@ minloc1_16_r16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_r16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_r16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_r16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_r4.c b/libgfortran/generated/minloc1_16_r4.c index 76e7efaf0eb..37cda9b2c1c 100644 --- a/libgfortran/generated/minloc1_16_r4.c +++ b/libgfortran/generated/minloc1_16_r4.c @@ -57,12 +57,15 @@ minloc1_16_r4 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_r4 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_r4 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_r4 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_16_r8.c b/libgfortran/generated/minloc1_16_r8.c index 97ca8661dfb..b0bbf82d313 100644 --- a/libgfortran/generated/minloc1_16_r8.c +++ b/libgfortran/generated/minloc1_16_r8.c @@ -57,12 +57,15 @@ minloc1_16_r8 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_16_r8 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_16 result; @@ -193,8 +197,8 @@ minloc1_16_r8 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_16_r8 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minloc1_16_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_i1.c b/libgfortran/generated/minloc1_4_i1.c index 330c0d9b91a..eab1b40109d 100644 --- a/libgfortran/generated/minloc1_4_i1.c +++ b/libgfortran/generated/minloc1_4_i1.c @@ -57,12 +57,15 @@ minloc1_4_i1 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_i1 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_i1 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_i1 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_i16.c b/libgfortran/generated/minloc1_4_i16.c index a142adb9630..3446e4e825d 100644 --- a/libgfortran/generated/minloc1_4_i16.c +++ b/libgfortran/generated/minloc1_4_i16.c @@ -57,12 +57,15 @@ minloc1_4_i16 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_i16 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_i16 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_i16 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_i2.c b/libgfortran/generated/minloc1_4_i2.c index d7a92804094..1e2a8c6652d 100644 --- a/libgfortran/generated/minloc1_4_i2.c +++ b/libgfortran/generated/minloc1_4_i2.c @@ -57,12 +57,15 @@ minloc1_4_i2 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_i2 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_i2 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_i2 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_i4.c b/libgfortran/generated/minloc1_4_i4.c index c6b12e84e26..6e4b137f183 100644 --- a/libgfortran/generated/minloc1_4_i4.c +++ b/libgfortran/generated/minloc1_4_i4.c @@ -57,12 +57,15 @@ minloc1_4_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_i8.c b/libgfortran/generated/minloc1_4_i8.c index bac4eb5fc82..5295a1050c7 100644 --- a/libgfortran/generated/minloc1_4_i8.c +++ b/libgfortran/generated/minloc1_4_i8.c @@ -57,12 +57,15 @@ minloc1_4_i8 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_i8 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_i8 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_i8 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_r10.c b/libgfortran/generated/minloc1_4_r10.c index 0579519ab0d..a020a9908a6 100644 --- a/libgfortran/generated/minloc1_4_r10.c +++ b/libgfortran/generated/minloc1_4_r10.c @@ -57,12 +57,15 @@ minloc1_4_r10 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_r10 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_r10 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_r10 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_r16.c b/libgfortran/generated/minloc1_4_r16.c index d74d26dc605..19bf03c3b75 100644 --- a/libgfortran/generated/minloc1_4_r16.c +++ b/libgfortran/generated/minloc1_4_r16.c @@ -57,12 +57,15 @@ minloc1_4_r16 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_r16 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_r16 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_r16 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_r4.c b/libgfortran/generated/minloc1_4_r4.c index 050ed5c3c79..ba54897ba39 100644 --- a/libgfortran/generated/minloc1_4_r4.c +++ b/libgfortran/generated/minloc1_4_r4.c @@ -57,12 +57,15 @@ minloc1_4_r4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_r4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_r4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_r4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_4_r8.c b/libgfortran/generated/minloc1_4_r8.c index 483cd19f262..07fb27a6606 100644 --- a/libgfortran/generated/minloc1_4_r8.c +++ b/libgfortran/generated/minloc1_4_r8.c @@ -57,12 +57,15 @@ minloc1_4_r8 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_4_r8 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_4 result; @@ -193,8 +197,8 @@ minloc1_4_r8 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_4_r8 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minloc1_4_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_i1.c b/libgfortran/generated/minloc1_8_i1.c index 1fc81d106e2..409a961a786 100644 --- a/libgfortran/generated/minloc1_8_i1.c +++ b/libgfortran/generated/minloc1_8_i1.c @@ -57,12 +57,15 @@ minloc1_8_i1 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_i1 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_i1 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_i1 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_i16.c b/libgfortran/generated/minloc1_8_i16.c index ecbabc7a981..47fc6665dec 100644 --- a/libgfortran/generated/minloc1_8_i16.c +++ b/libgfortran/generated/minloc1_8_i16.c @@ -57,12 +57,15 @@ minloc1_8_i16 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_i16 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_i16 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_i16 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_i2.c b/libgfortran/generated/minloc1_8_i2.c index 2c03443258e..22080173f89 100644 --- a/libgfortran/generated/minloc1_8_i2.c +++ b/libgfortran/generated/minloc1_8_i2.c @@ -57,12 +57,15 @@ minloc1_8_i2 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_i2 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_i2 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_i2 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_i4.c b/libgfortran/generated/minloc1_8_i4.c index 945423748c5..71df4e662e3 100644 --- a/libgfortran/generated/minloc1_8_i4.c +++ b/libgfortran/generated/minloc1_8_i4.c @@ -57,12 +57,15 @@ minloc1_8_i4 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_i4 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_i4 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_i4 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_i8.c b/libgfortran/generated/minloc1_8_i8.c index df801458e09..d4e471a62bb 100644 --- a/libgfortran/generated/minloc1_8_i8.c +++ b/libgfortran/generated/minloc1_8_i8.c @@ -57,12 +57,15 @@ minloc1_8_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_r10.c b/libgfortran/generated/minloc1_8_r10.c index 364bf5c6f04..61632394d6c 100644 --- a/libgfortran/generated/minloc1_8_r10.c +++ b/libgfortran/generated/minloc1_8_r10.c @@ -57,12 +57,15 @@ minloc1_8_r10 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_r10 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_r10 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_r10 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_r16.c b/libgfortran/generated/minloc1_8_r16.c index b8ad0950ec5..3e0416adb52 100644 --- a/libgfortran/generated/minloc1_8_r16.c +++ b/libgfortran/generated/minloc1_8_r16.c @@ -57,12 +57,15 @@ minloc1_8_r16 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_r16 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_r16 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_r16 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_r4.c b/libgfortran/generated/minloc1_8_r4.c index e9df66c669f..c6a6ad4bc55 100644 --- a/libgfortran/generated/minloc1_8_r4.c +++ b/libgfortran/generated/minloc1_8_r4.c @@ -57,12 +57,15 @@ minloc1_8_r4 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_r4 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_r4 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_r4 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/minloc1_8_r8.c b/libgfortran/generated/minloc1_8_r8.c index 7d2cfff7fed..8a01e3edf26 100644 --- a/libgfortran/generated/minloc1_8_r8.c +++ b/libgfortran/generated/minloc1_8_r8.c @@ -57,12 +57,15 @@ minloc1_8_r8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -149,7 +152,8 @@ minloc1_8_r8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_INTEGER_8 result; @@ -193,8 +197,8 @@ minloc1_8_r8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -428,51 +432,131 @@ sminloc1_8_r8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minloc1_8_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINLOC intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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_i1.c b/libgfortran/generated/minval_i1.c index 1789ec9fcfa..719a0497c6c 100644 --- a/libgfortran/generated/minval_i1.c +++ b/libgfortran/generated/minval_i1.c @@ -56,12 +56,15 @@ minval_i1 (gfc_array_i1 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_i1 (gfc_array_i1 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_1 result; @@ -187,8 +191,8 @@ minval_i1 (gfc_array_i1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_i1 (gfc_array_i1 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_1 *dest; + index_type dim; + if (*mask) { minval_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_INTEGER_1_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_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_i16.c b/libgfortran/generated/minval_i16.c index 2916256e3eb..c4f699b01b1 100644 --- a/libgfortran/generated/minval_i16.c +++ b/libgfortran/generated/minval_i16.c @@ -56,12 +56,15 @@ minval_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -187,8 +191,8 @@ minval_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { minval_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_INTEGER_16_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_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_i2.c b/libgfortran/generated/minval_i2.c index 73bf18b6167..2ff292fe9b1 100644 --- a/libgfortran/generated/minval_i2.c +++ b/libgfortran/generated/minval_i2.c @@ -56,12 +56,15 @@ minval_i2 (gfc_array_i2 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_i2 (gfc_array_i2 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_2 result; @@ -187,8 +191,8 @@ minval_i2 (gfc_array_i2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_i2 (gfc_array_i2 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_2 *dest; + index_type dim; + if (*mask) { minval_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_INTEGER_2_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_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_i4.c b/libgfortran/generated/minval_i4.c index 8d6e52a2ac0..96bfe32bde6 100644 --- a/libgfortran/generated/minval_i4.c +++ b/libgfortran/generated/minval_i4.c @@ -56,12 +56,15 @@ minval_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -187,8 +191,8 @@ minval_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { minval_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_INTEGER_4_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_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_i8.c b/libgfortran/generated/minval_i8.c index 22cf462d060..1682dd2fa39 100644 --- a/libgfortran/generated/minval_i8.c +++ b/libgfortran/generated/minval_i8.c @@ -56,12 +56,15 @@ minval_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -187,8 +191,8 @@ minval_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { minval_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_INTEGER_8_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_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_r10.c b/libgfortran/generated/minval_r10.c index f4d467c0d99..fa9e6366e38 100644 --- a/libgfortran/generated/minval_r10.c +++ b/libgfortran/generated/minval_r10.c @@ -56,12 +56,15 @@ minval_r10 (gfc_array_r10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_r10 (gfc_array_r10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_REAL_10 result; @@ -187,8 +191,8 @@ minval_r10 (gfc_array_r10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_r10 (gfc_array_r10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_10 *dest; + index_type dim; + if (*mask) { minval_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_REAL_10_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_10_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_r16.c b/libgfortran/generated/minval_r16.c index 7ba19c99c1b..9561caa94da 100644 --- a/libgfortran/generated/minval_r16.c +++ b/libgfortran/generated/minval_r16.c @@ -56,12 +56,15 @@ minval_r16 (gfc_array_r16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_r16 (gfc_array_r16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_REAL_16 result; @@ -187,8 +191,8 @@ minval_r16 (gfc_array_r16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_r16 (gfc_array_r16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_16 *dest; + index_type dim; + if (*mask) { minval_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_REAL_16_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_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_r4.c b/libgfortran/generated/minval_r4.c index 3b29f2f5d3b..ac048eedb06 100644 --- a/libgfortran/generated/minval_r4.c +++ b/libgfortran/generated/minval_r4.c @@ -56,12 +56,15 @@ minval_r4 (gfc_array_r4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_r4 (gfc_array_r4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_REAL_4 result; @@ -187,8 +191,8 @@ minval_r4 (gfc_array_r4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_r4 (gfc_array_r4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_4 *dest; + index_type dim; + if (*mask) { minval_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_REAL_4_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_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_r8.c b/libgfortran/generated/minval_r8.c index adca8b28c7d..21ecb3c5afb 100644 --- a/libgfortran/generated/minval_r8.c +++ b/libgfortran/generated/minval_r8.c @@ -56,12 +56,15 @@ minval_r8 (gfc_array_r8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ minval_r8 (gfc_array_r8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_REAL_8 result; @@ -187,8 +191,8 @@ minval_r8 (gfc_array_r8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -417,51 +421,131 @@ sminval_r8 (gfc_array_r8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_8 *dest; + index_type dim; + if (*mask) { minval_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } 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 (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in MINVAL intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + 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]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = GFC_REAL_8_HUGE ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_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/pack_c10.c b/libgfortran/generated/pack_c10.c index c9a0c58a5b5..0bad32385d8 100644 --- a/libgfortran/generated/pack_c10.c +++ b/libgfortran/generated/pack_c10.c @@ -103,7 +103,6 @@ pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, } #endif + diff --git a/libgfortran/generated/pack_c16.c b/libgfortran/generated/pack_c16.c index 2996be2d220..a0c87ec8a26 100644 --- a/libgfortran/generated/pack_c16.c +++ b/libgfortran/generated/pack_c16.c @@ -103,7 +103,6 @@ pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, } #endif + diff --git a/libgfortran/generated/pack_c4.c b/libgfortran/generated/pack_c4.c index ee41c0b8cbf..2fb6a20ad9c 100644 --- a/libgfortran/generated/pack_c4.c +++ b/libgfortran/generated/pack_c4.c @@ -103,7 +103,6 @@ pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, } #endif + diff --git a/libgfortran/generated/pack_c8.c b/libgfortran/generated/pack_c8.c index a129422e04f..1a4e78ec792 100644 --- a/libgfortran/generated/pack_c8.c +++ b/libgfortran/generated/pack_c8.c @@ -103,7 +103,6 @@ pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, } #endif + diff --git a/libgfortran/generated/pack_i1.c b/libgfortran/generated/pack_i1.c index 25d7f569de5..44c6c677e44 100644 --- a/libgfortran/generated/pack_i1.c +++ b/libgfortran/generated/pack_i1.c @@ -103,7 +103,6 @@ pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, } #endif + diff --git a/libgfortran/generated/pack_i16.c b/libgfortran/generated/pack_i16.c index 35c64ce8a9e..e9c15437977 100644 --- a/libgfortran/generated/pack_i16.c +++ b/libgfortran/generated/pack_i16.c @@ -103,7 +103,6 @@ pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, } #endif + diff --git a/libgfortran/generated/pack_i2.c b/libgfortran/generated/pack_i2.c index 3a42bd38d78..51380c26ba7 100644 --- a/libgfortran/generated/pack_i2.c +++ b/libgfortran/generated/pack_i2.c @@ -103,7 +103,6 @@ pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, } #endif + diff --git a/libgfortran/generated/pack_i4.c b/libgfortran/generated/pack_i4.c index 28e09f6abec..861670d6865 100644 --- a/libgfortran/generated/pack_i4.c +++ b/libgfortran/generated/pack_i4.c @@ -103,7 +103,6 @@ pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, } #endif + diff --git a/libgfortran/generated/pack_i8.c b/libgfortran/generated/pack_i8.c index 44fc430782f..c547f3809f2 100644 --- a/libgfortran/generated/pack_i8.c +++ b/libgfortran/generated/pack_i8.c @@ -103,7 +103,6 @@ pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, } #endif + diff --git a/libgfortran/generated/pack_r10.c b/libgfortran/generated/pack_r10.c index 72fe254d918..4b8c5784aef 100644 --- a/libgfortran/generated/pack_r10.c +++ b/libgfortran/generated/pack_r10.c @@ -103,7 +103,6 @@ pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, } #endif + diff --git a/libgfortran/generated/pack_r16.c b/libgfortran/generated/pack_r16.c index 0ced53ab017..a691f7c4041 100644 --- a/libgfortran/generated/pack_r16.c +++ b/libgfortran/generated/pack_r16.c @@ -103,7 +103,6 @@ pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, } #endif + diff --git a/libgfortran/generated/pack_r4.c b/libgfortran/generated/pack_r4.c index 17172ed92a8..c008aadf4d4 100644 --- a/libgfortran/generated/pack_r4.c +++ b/libgfortran/generated/pack_r4.c @@ -103,7 +103,6 @@ pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, } #endif + diff --git a/libgfortran/generated/pack_r8.c b/libgfortran/generated/pack_r8.c index 9d0fb5b5d78..7b360479628 100644 --- a/libgfortran/generated/pack_r8.c +++ b/libgfortran/generated/pack_r8.c @@ -103,7 +103,6 @@ pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -139,6 +138,11 @@ pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -149,6 +153,11 @@ pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -308,3 +317,4 @@ pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, } #endif + diff --git a/libgfortran/generated/product_c10.c b/libgfortran/generated/product_c10.c index def678ab953..66a9c05dec7 100644 --- a/libgfortran/generated/product_c10.c +++ b/libgfortran/generated/product_c10.c @@ -56,12 +56,15 @@ product_c10 (gfc_array_c10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_c10 (gfc_array_c10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_10 * restrict src; GFC_COMPLEX_10 result; @@ -186,8 +190,8 @@ product_c10 (gfc_array_c10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_c10 (gfc_array_c10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_10 *dest; + index_type dim; + if (*mask) { product_c10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_c16.c b/libgfortran/generated/product_c16.c index d8750aef5b0..ec2acb4e4f9 100644 --- a/libgfortran/generated/product_c16.c +++ b/libgfortran/generated/product_c16.c @@ -56,12 +56,15 @@ product_c16 (gfc_array_c16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_c16 (gfc_array_c16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_16 * restrict src; GFC_COMPLEX_16 result; @@ -186,8 +190,8 @@ product_c16 (gfc_array_c16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_c16 (gfc_array_c16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_16 *dest; + index_type dim; + if (*mask) { product_c16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_c4.c b/libgfortran/generated/product_c4.c index 7cac33fc8c6..bd52eb9ab77 100644 --- a/libgfortran/generated/product_c4.c +++ b/libgfortran/generated/product_c4.c @@ -56,12 +56,15 @@ product_c4 (gfc_array_c4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_c4 (gfc_array_c4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_4 * restrict src; GFC_COMPLEX_4 result; @@ -186,8 +190,8 @@ product_c4 (gfc_array_c4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_c4 (gfc_array_c4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_4 *dest; + index_type dim; + if (*mask) { product_c4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_c8.c b/libgfortran/generated/product_c8.c index e4f0f6bfd30..c124355c1b2 100644 --- a/libgfortran/generated/product_c8.c +++ b/libgfortran/generated/product_c8.c @@ -56,12 +56,15 @@ product_c8 (gfc_array_c8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_c8 (gfc_array_c8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_8 * restrict src; GFC_COMPLEX_8 result; @@ -186,8 +190,8 @@ product_c8 (gfc_array_c8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_c8 (gfc_array_c8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_8 *dest; + index_type dim; + if (*mask) { product_c8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_i1.c b/libgfortran/generated/product_i1.c index 5a428cad202..362a08ac6a1 100644 --- a/libgfortran/generated/product_i1.c +++ b/libgfortran/generated/product_i1.c @@ -56,12 +56,15 @@ product_i1 (gfc_array_i1 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_i1 (gfc_array_i1 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_1 result; @@ -186,8 +190,8 @@ product_i1 (gfc_array_i1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_i1 (gfc_array_i1 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_1 *dest; + index_type dim; + if (*mask) { product_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_i16.c b/libgfortran/generated/product_i16.c index a1593a4f66a..a687c3a218e 100644 --- a/libgfortran/generated/product_i16.c +++ b/libgfortran/generated/product_i16.c @@ -56,12 +56,15 @@ product_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -186,8 +190,8 @@ product_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { product_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_i2.c b/libgfortran/generated/product_i2.c index 16793f89579..f8082b4c7bb 100644 --- a/libgfortran/generated/product_i2.c +++ b/libgfortran/generated/product_i2.c @@ -56,12 +56,15 @@ product_i2 (gfc_array_i2 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_i2 (gfc_array_i2 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_2 result; @@ -186,8 +190,8 @@ product_i2 (gfc_array_i2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_i2 (gfc_array_i2 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_2 *dest; + index_type dim; + if (*mask) { product_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_i4.c b/libgfortran/generated/product_i4.c index cbace913d6a..11132d4e2bb 100644 --- a/libgfortran/generated/product_i4.c +++ b/libgfortran/generated/product_i4.c @@ -56,12 +56,15 @@ product_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -186,8 +190,8 @@ product_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { product_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_i8.c b/libgfortran/generated/product_i8.c index f1fc56718a8..da28568f39e 100644 --- a/libgfortran/generated/product_i8.c +++ b/libgfortran/generated/product_i8.c @@ -56,12 +56,15 @@ product_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -186,8 +190,8 @@ product_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { product_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_r10.c b/libgfortran/generated/product_r10.c index 4b7c5803096..fb0074e2226 100644 --- a/libgfortran/generated/product_r10.c +++ b/libgfortran/generated/product_r10.c @@ -56,12 +56,15 @@ product_r10 (gfc_array_r10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_r10 (gfc_array_r10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_REAL_10 result; @@ -186,8 +190,8 @@ product_r10 (gfc_array_r10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_r10 (gfc_array_r10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_10 *dest; + index_type dim; + if (*mask) { product_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_r16.c b/libgfortran/generated/product_r16.c index b18155bd73c..2375cbefef5 100644 --- a/libgfortran/generated/product_r16.c +++ b/libgfortran/generated/product_r16.c @@ -56,12 +56,15 @@ product_r16 (gfc_array_r16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_r16 (gfc_array_r16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_REAL_16 result; @@ -186,8 +190,8 @@ product_r16 (gfc_array_r16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_r16 (gfc_array_r16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_16 *dest; + index_type dim; + if (*mask) { product_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_r4.c b/libgfortran/generated/product_r4.c index 754cac2bfb1..1a3aacc3b79 100644 --- a/libgfortran/generated/product_r4.c +++ b/libgfortran/generated/product_r4.c @@ -56,12 +56,15 @@ product_r4 (gfc_array_r4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_r4 (gfc_array_r4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_REAL_4 result; @@ -186,8 +190,8 @@ product_r4 (gfc_array_r4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_r4 (gfc_array_r4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_4 *dest; + index_type dim; + if (*mask) { product_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/product_r8.c b/libgfortran/generated/product_r8.c index 5f68856a8b0..76cb1bedbbf 100644 --- a/libgfortran/generated/product_r8.c +++ b/libgfortran/generated/product_r8.c @@ -56,12 +56,15 @@ product_r8 (gfc_array_r8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ product_r8 (gfc_array_r8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_REAL_8 result; @@ -186,8 +190,8 @@ product_r8 (gfc_array_r8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ sproduct_r8 (gfc_array_r8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_8 *dest; + index_type dim; + if (*mask) { product_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in PRODUCT intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + 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/reshape_c10.c b/libgfortran/generated/reshape_c10.c index 28cad4a0b6e..732d947a8da 100644 --- a/libgfortran/generated/reshape_c10.c +++ b/libgfortran/generated/reshape_c10.c @@ -131,7 +131,7 @@ reshape_c10 (gfc_array_c10 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_c16.c b/libgfortran/generated/reshape_c16.c index ce658dae668..71532c929ef 100644 --- a/libgfortran/generated/reshape_c16.c +++ b/libgfortran/generated/reshape_c16.c @@ -131,7 +131,7 @@ reshape_c16 (gfc_array_c16 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_c4.c b/libgfortran/generated/reshape_c4.c index fd33a954a06..4253b066815 100644 --- a/libgfortran/generated/reshape_c4.c +++ b/libgfortran/generated/reshape_c4.c @@ -131,7 +131,7 @@ reshape_c4 (gfc_array_c4 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_c8.c b/libgfortran/generated/reshape_c8.c index d23cf88c0a3..add90f2f205 100644 --- a/libgfortran/generated/reshape_c8.c +++ b/libgfortran/generated/reshape_c8.c @@ -131,7 +131,7 @@ reshape_c8 (gfc_array_c8 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_i16.c b/libgfortran/generated/reshape_i16.c index c9b3694c5de..e2d5a275842 100644 --- a/libgfortran/generated/reshape_i16.c +++ b/libgfortran/generated/reshape_i16.c @@ -131,7 +131,7 @@ reshape_16 (gfc_array_i16 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_i4.c b/libgfortran/generated/reshape_i4.c index 4a55b68fed6..3e0c9d68542 100644 --- a/libgfortran/generated/reshape_i4.c +++ b/libgfortran/generated/reshape_i4.c @@ -94,10 +94,10 @@ reshape_4 (gfc_array_i4 * const restrict ret, { shape_data[n] = shape->data[n * shape->dim[0].stride]; if (shape_data[n] <= 0) - { - shape_data[n] = 0; - shape_empty = 1; - } + { + shape_data[n] = 0; + shape_empty = 1; + } } if (ret->data == NULL) @@ -131,7 +131,7 @@ reshape_4 (gfc_array_i4 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_i8.c b/libgfortran/generated/reshape_i8.c index d496ca9d7ef..bf3185e1c2c 100644 --- a/libgfortran/generated/reshape_i8.c +++ b/libgfortran/generated/reshape_i8.c @@ -131,7 +131,7 @@ reshape_8 (gfc_array_i8 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_r10.c b/libgfortran/generated/reshape_r10.c index 61e367c96ce..9f6159aeafb 100644 --- a/libgfortran/generated/reshape_r10.c +++ b/libgfortran/generated/reshape_r10.c @@ -131,7 +131,7 @@ reshape_r10 (gfc_array_r10 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_r16.c b/libgfortran/generated/reshape_r16.c index f04fe32c6a8..69578f033a5 100644 --- a/libgfortran/generated/reshape_r16.c +++ b/libgfortran/generated/reshape_r16.c @@ -131,7 +131,7 @@ reshape_r16 (gfc_array_r16 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_r4.c b/libgfortran/generated/reshape_r4.c index 0323a724624..112dbf2955d 100644 --- a/libgfortran/generated/reshape_r4.c +++ b/libgfortran/generated/reshape_r4.c @@ -131,7 +131,7 @@ reshape_r4 (gfc_array_r4 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/reshape_r8.c b/libgfortran/generated/reshape_r8.c index e6be1ef03be..015546ffe1a 100644 --- a/libgfortran/generated/reshape_r8.c +++ b/libgfortran/generated/reshape_r8.c @@ -131,7 +131,7 @@ reshape_r8 (gfc_array_r8 * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/generated/sum_c10.c b/libgfortran/generated/sum_c10.c index e495a0ba497..0c53b6c5880 100644 --- a/libgfortran/generated/sum_c10.c +++ b/libgfortran/generated/sum_c10.c @@ -56,12 +56,15 @@ sum_c10 (gfc_array_c10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_c10 (gfc_array_c10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_10 * restrict src; GFC_COMPLEX_10 result; @@ -186,8 +190,8 @@ sum_c10 (gfc_array_c10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_c10 (gfc_array_c10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_10 *dest; + index_type dim; + if (*mask) { sum_c10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_c16.c b/libgfortran/generated/sum_c16.c index c73083a930c..a3db7aa7d2a 100644 --- a/libgfortran/generated/sum_c16.c +++ b/libgfortran/generated/sum_c16.c @@ -56,12 +56,15 @@ sum_c16 (gfc_array_c16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_c16 (gfc_array_c16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_16 * restrict src; GFC_COMPLEX_16 result; @@ -186,8 +190,8 @@ sum_c16 (gfc_array_c16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_c16 (gfc_array_c16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_16 *dest; + index_type dim; + if (*mask) { sum_c16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_c4.c b/libgfortran/generated/sum_c4.c index 6f32327ad0b..849ab8a21ba 100644 --- a/libgfortran/generated/sum_c4.c +++ b/libgfortran/generated/sum_c4.c @@ -56,12 +56,15 @@ sum_c4 (gfc_array_c4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_c4 (gfc_array_c4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_4 * restrict src; GFC_COMPLEX_4 result; @@ -186,8 +190,8 @@ sum_c4 (gfc_array_c4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_c4 (gfc_array_c4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_4 *dest; + index_type dim; + if (*mask) { sum_c4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_c8.c b/libgfortran/generated/sum_c8.c index 80db1101cfe..dcdcadfcda9 100644 --- a/libgfortran/generated/sum_c8.c +++ b/libgfortran/generated/sum_c8.c @@ -56,12 +56,15 @@ sum_c8 (gfc_array_c8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_c8 (gfc_array_c8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_COMPLEX_8 * restrict src; GFC_COMPLEX_8 result; @@ -186,8 +190,8 @@ sum_c8 (gfc_array_c8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_c8 (gfc_array_c8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_COMPLEX_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_COMPLEX_8 *dest; + index_type dim; + if (*mask) { sum_c8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_i1.c b/libgfortran/generated/sum_i1.c index c652712d4e7..7b396818b53 100644 --- a/libgfortran/generated/sum_i1.c +++ b/libgfortran/generated/sum_i1.c @@ -56,12 +56,15 @@ sum_i1 (gfc_array_i1 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_i1 (gfc_array_i1 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_1 * restrict src; GFC_INTEGER_1 result; @@ -186,8 +190,8 @@ sum_i1 (gfc_array_i1 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_i1 (gfc_array_i1 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_1 *dest; + index_type dim; + if (*mask) { sum_i1 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_i16.c b/libgfortran/generated/sum_i16.c index 43a29a2956f..e99da269b81 100644 --- a/libgfortran/generated/sum_i16.c +++ b/libgfortran/generated/sum_i16.c @@ -56,12 +56,15 @@ sum_i16 (gfc_array_i16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_i16 (gfc_array_i16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_16 * restrict src; GFC_INTEGER_16 result; @@ -186,8 +190,8 @@ sum_i16 (gfc_array_i16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_i16 (gfc_array_i16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_16 *dest; + index_type dim; + if (*mask) { sum_i16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_i2.c b/libgfortran/generated/sum_i2.c index 6c6fcc1116a..8a61191a8f9 100644 --- a/libgfortran/generated/sum_i2.c +++ b/libgfortran/generated/sum_i2.c @@ -56,12 +56,15 @@ sum_i2 (gfc_array_i2 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_i2 (gfc_array_i2 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_2 * restrict src; GFC_INTEGER_2 result; @@ -186,8 +190,8 @@ sum_i2 (gfc_array_i2 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_i2 (gfc_array_i2 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_2 *dest; + index_type dim; + if (*mask) { sum_i2 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_i4.c b/libgfortran/generated/sum_i4.c index e28d2c96fdf..f7912ff7aa4 100644 --- a/libgfortran/generated/sum_i4.c +++ b/libgfortran/generated/sum_i4.c @@ -56,12 +56,15 @@ sum_i4 (gfc_array_i4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_i4 (gfc_array_i4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_4 * restrict src; GFC_INTEGER_4 result; @@ -186,8 +190,8 @@ sum_i4 (gfc_array_i4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_i4 (gfc_array_i4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_4 *dest; + index_type dim; + if (*mask) { sum_i4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_i8.c b/libgfortran/generated/sum_i8.c index 6e824f1ca56..a8ad4a5a9af 100644 --- a/libgfortran/generated/sum_i8.c +++ b/libgfortran/generated/sum_i8.c @@ -56,12 +56,15 @@ sum_i8 (gfc_array_i8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_i8 (gfc_array_i8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_INTEGER_8 * restrict src; GFC_INTEGER_8 result; @@ -186,8 +190,8 @@ sum_i8 (gfc_array_i8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_i8 (gfc_array_i8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_INTEGER_8 *dest; + index_type dim; + if (*mask) { sum_i8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_r10.c b/libgfortran/generated/sum_r10.c index 1ebd1ed5425..f96c72cc70b 100644 --- a/libgfortran/generated/sum_r10.c +++ b/libgfortran/generated/sum_r10.c @@ -56,12 +56,15 @@ sum_r10 (gfc_array_r10 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_r10 (gfc_array_r10 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_10 * restrict src; GFC_REAL_10 result; @@ -186,8 +190,8 @@ sum_r10 (gfc_array_r10 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_r10 (gfc_array_r10 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_10 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_10 *dest; + index_type dim; + if (*mask) { sum_r10 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_10) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_r16.c b/libgfortran/generated/sum_r16.c index 0038983a6b4..dd8bdcf4dc0 100644 --- a/libgfortran/generated/sum_r16.c +++ b/libgfortran/generated/sum_r16.c @@ -56,12 +56,15 @@ sum_r16 (gfc_array_r16 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_r16 (gfc_array_r16 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_16 * restrict src; GFC_REAL_16 result; @@ -186,8 +190,8 @@ sum_r16 (gfc_array_r16 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_r16 (gfc_array_r16 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_16 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_16 *dest; + index_type dim; + if (*mask) { sum_r16 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_16) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_r4.c b/libgfortran/generated/sum_r4.c index 1f058dcbda0..3a39c27f88e 100644 --- a/libgfortran/generated/sum_r4.c +++ b/libgfortran/generated/sum_r4.c @@ -56,12 +56,15 @@ sum_r4 (gfc_array_r4 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_r4 (gfc_array_r4 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_4 * restrict src; GFC_REAL_4 result; @@ -186,8 +190,8 @@ sum_r4 (gfc_array_r4 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_r4 (gfc_array_r4 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_4 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_4 *dest; + index_type dim; + if (*mask) { sum_r4 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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/sum_r8.c b/libgfortran/generated/sum_r8.c index 82a03bc81f7..858174ab430 100644 --- a/libgfortran/generated/sum_r8.c +++ b/libgfortran/generated/sum_r8.c @@ -56,12 +56,15 @@ sum_r8 (gfc_array_r8 * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -148,7 +151,8 @@ sum_r8 (gfc_array_r8 * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_REAL_8 * restrict src; GFC_REAL_8 result; @@ -186,8 +190,8 @@ sum_r8 (gfc_array_r8 * const restrict retarray, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -416,51 +420,131 @@ ssum_r8 (gfc_array_r8 * const restrict retarray, const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + GFC_REAL_8 * restrict dest; index_type rank; index_type n; - index_type dstride; - GFC_REAL_8 *dest; + index_type dim; + if (*mask) { sum_r8 (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (GFC_REAL_8) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in SUM intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = 0 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + 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 2d0537246e3..0c6b7b1b7af 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1037,6 +1037,7 @@ GFORTRAN_1.1 { _gfortran_erfc_scaled_r8; _gfortran_erfc_scaled_r10; _gfortran_erfc_scaled_r16; + _gfortran_selected_char_kind; _gfortran_st_wait; } GFORTRAN_1.0; diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index e282c916502..bb4abaeae4b 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -491,6 +491,7 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, index_type dim; index_type ssize; index_type nelem; + index_type total; dim = GFC_DESCRIPTOR_RANK (array); ssize = 1; @@ -498,6 +499,9 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, { count[n] = 0; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] < 0) + extent[n] = 0; + sstride[n] = array->dim[n].stride * size; ssize *= extent[n]; } @@ -505,18 +509,26 @@ pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, sstride[0] = size; sstride0 = sstride[0]; - sptr = array->data; + + if (ssize != 0) + sptr = array->data; + else + sptr = NULL; if (ret->data == NULL) { /* Allocate the memory for the result. */ - int total; if (vector != NULL) { /* The return array will have as many elements as there are in vector. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total <= 0) + { + total = 0; + vector = NULL; + } } else { diff --git a/libgfortran/intrinsics/selected_char_kind.c b/libgfortran/intrinsics/selected_char_kind.c new file mode 100644 index 00000000000..c10d5b2efaf --- /dev/null +++ b/libgfortran/intrinsics/selected_char_kind.c @@ -0,0 +1,49 @@ +/* Copyright 2008 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +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. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + + +#include "libgfortran.h" + +#include <string.h> + + +extern GFC_INTEGER_4 selected_char_kind (gfc_charlen_type, char *); +export_proto(selected_char_kind); + +GFC_INTEGER_4 +selected_char_kind (gfc_charlen_type name_len, char *name) +{ + gfc_charlen_type len = fstrlen (name, name_len); + + if ((len == 5 && strncasecmp (name, "ascii", 5) == 0) + || (len == 7 && strncasecmp (name, "default", 7) == 0)) + return 1; + else + return -1; +} diff --git a/libgfortran/intrinsics/time_1.h b/libgfortran/intrinsics/time_1.h index 93b3d2dc467..3dcb9d5f5ae 100644 --- a/libgfortran/intrinsics/time_1.h +++ b/libgfortran/intrinsics/time_1.h @@ -87,7 +87,6 @@ __time_1 (long *user_sec, long *user_usec, long *system_sec, long *system_usec) } kernel_time, user_time; FILETIME unused1, unused2; - unsigned long long total_time; /* No support for Win9x. The high order bit of the DWORD returned by GetVersion is 0 for NT and higher. */ diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index 4e904d37df9..83e37ee22fd 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -107,7 +107,7 @@ static const st_option decimal_opt[] = static const st_option encoding_opt[] = { - { "utf-8", ENCODING_UTF8}, + /* TODO { "utf-8", ENCODING_UTF8}, */ { "default", ENCODING_DEFAULT}, { NULL, 0} }; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 8741758e61d..7071ab9128a 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1303,11 +1303,6 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len, else read_x (dtp, dtp->u.p.skips); } - else - { - if (dtp->u.p.skips < 0) - flush (dtp->u.p.current_unit->s); - } break; @@ -2682,8 +2677,7 @@ next_record_w (st_parameter_dt *dtp, int done) if (max_pos > m) { length = (int) (max_pos - m); - sseek (dtp->u.p.current_unit->s, - file_position (dtp->u.p.current_unit->s) + length); + p = salloc_w (dtp->u.p.current_unit->s, &length); } #ifdef HAVE_CRLF len = 2; diff --git a/libgfortran/m4/ifunction.m4 b/libgfortran/m4/ifunction.m4 index 9769e4d2ddb..edf3c77d05c 100644 --- a/libgfortran/m4/ifunction.m4 +++ b/libgfortran/m4/ifunction.m4 @@ -39,12 +39,15 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, index_type len; index_type delta; index_type dim; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; delta = array->dim[dim].stride; for (n = 0; n < dim; n++) @@ -131,7 +134,8 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, base = array->data; dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const atype_name * restrict src; rtype_name result; @@ -169,8 +173,8 @@ define(FINISH_ARRAY_FUNCTION, if (n == rank) { /* Break out of the look. */ - base = NULL; - break; + continue_loop = 0; + break; } else { @@ -398,51 +402,131 @@ void const index_type * const restrict pdim, GFC_LOGICAL_4 * 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]; + rtype_name * restrict dest; index_type rank; index_type n; - index_type dstride; - rtype_name *dest; + index_type dim; + if (*mask) { name`'rtype_qual`_'atype_code (retarray, array, pdim); return; } - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] <= 0) + extent[n] = 0; + } if (retarray->data == NULL) { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); } else { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + if (compile_options.bounds_check) { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in u_name intrinsic" - " should be 1, is %ld", (long int) ret_rank); + for (n=0; n < rank; n++) + { + index_type ret_extent; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } } } - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - dest[n * dstride] = $1 ; + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + } + + dest = retarray->data; + + while(1) + { + *dest = '$1`; + 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]; + } + } + } }')dnl define(ARRAY_FUNCTION, `START_ARRAY_FUNCTION diff --git a/libgfortran/m4/ifunction_logical.m4 b/libgfortran/m4/ifunction_logical.m4 index 8666870c88e..a31d73a17b9 100644 --- a/libgfortran/m4/ifunction_logical.m4 +++ b/libgfortran/m4/ifunction_logical.m4 @@ -40,6 +40,7 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, index_type delta; index_type dim; int src_kind; + int continue_loop; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; @@ -48,6 +49,9 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, src_kind = GFC_DESCRIPTOR_SIZE (array); len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (len < 0) + len = 0; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) @@ -147,7 +151,8 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, dest = retarray->data; - while (base) + continue_loop = 1; + while (continue_loop) { const GFC_LOGICAL_1 * restrict src; rtype_name result; @@ -185,7 +190,7 @@ define(FINISH_ARRAY_FUNCTION, if (n == rank) { /* Break out of the look. */ - base = NULL; + continue_loop = 0; break; } else diff --git a/libgfortran/m4/matmul.m4 b/libgfortran/m4/matmul.m4 index a290bfe1f06..181efa3b654 100644 --- a/libgfortran/m4/matmul.m4 +++ b/libgfortran/m4/matmul.m4 @@ -172,7 +172,10 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl } if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + { + if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } if (GFC_DESCRIPTOR_RANK (b) == 1) { diff --git a/libgfortran/m4/pack.m4 b/libgfortran/m4/pack.m4 index 87409a56223..4f31ffdd15e 100644 --- a/libgfortran/m4/pack.m4 +++ b/libgfortran/m4/pack.m4 @@ -104,7 +104,6 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, dim = GFC_DESCRIPTOR_RANK (array); - sptr = array->data; mptr = mask->data; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 @@ -140,6 +139,11 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, if (mstride[0] == 0) mstride[0] = mask_kind; + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + if (ret->data == NULL || compile_options.bounds_check) { /* Count the elements, either for allocating memory or @@ -150,6 +154,11 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, /* The return array will have as many elements as there are in VECTOR. */ total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total < 0) + { + total = 0; + vector = NULL; + } } else { @@ -309,4 +318,4 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, } #endif -'
\ No newline at end of file +' diff --git a/libgfortran/m4/reshape.m4 b/libgfortran/m4/reshape.m4 index ed060ecb9ff..a10ad715584 100644 --- a/libgfortran/m4/reshape.m4 +++ b/libgfortran/m4/reshape.m4 @@ -135,7 +135,7 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, rstride[n] = ret->dim[dim].stride; rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; if (rextent[n] < 0) - rextent[n] == 0; + rextent[n] = 0; if (rextent[n] != shape_data[dim]) runtime_error ("shape and target do not conform"); diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index f0a4ff2291d..8cd966fa23f 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -202,6 +202,11 @@ show_locus (st_parameter_common *cmp) (int) cmp->line, cmp->filename, cmp->unit, filename); free_mem (filename); } + else + { + st_printf ("At line %d of file %s (unit = %d)\n", + (int) cmp->line, cmp->filename, cmp->unit); + } return; } |