diff options
| author | Thomas Koenig <tkoenig@gcc.gnu.org> | 2017-12-03 20:14:05 +0000 |
|---|---|---|
| committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2017-12-03 20:14:05 +0000 |
| commit | 0ac7425470a37554aa4dd017afb5f90b7328c9b0 (patch) | |
| tree | b31908b5003acf7307242caf1ae5698a3d2a3fb9 /libgfortran | |
| parent | af5ad1e2e56a91db15c1f714f5f513ad54a07eeb (diff) | |
re PR fortran/36313 ([F03] {MIN,MAX}{LOC,VAL} should accept character arguments)
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* check.c (gfc_check_minval_maxval): Use
int_orLreal_or_char_check_f2003 for array argument.
* iresolve.c (gfc_resolve_maxval): Insert number in
function name for character arguments.
(gfc_resolve_minval): Likewise.
* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc):
Fix comment.
(gfc_conv_intrinsic_minmaxval): Resort arguments and call library
function if dealing with a character function.
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* Makefile.am: Add new files for character-valued
maxval and minval.
* Makefile.in: Regenerated.
* gfortran.map: Add new functions.
* m4/iforeach-s2.m4: New file.
* m4/ifunction-s2.m4: New file.
* m4/iparm.m4: Add intitval for minval and maxval.
* m4/maxval0s.m4: New file.
* m4/maxval1s.m4: New file.
* m4/minval0s.m4: New file.
* m4/minval1s.m4: New file.
* generated/maxval0_s1.c: New file.
* generated/maxval0_s4.c: New file.
* generated/maxval1_s1.c: New file.
* generated/maxval1_s4.c: New file.
* generated/minval0_s1.c: New file.
* generated/minval0_s4.c: New file.
* generated/minval1_s1.c: New file.
* generated/minval1_s4.c: New file.
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* gfortran.dg/maxval_char_1.f90: New test.
* gfortran.dg/maxval_char_2.f90: New test.
* gfortran.dg/maxval_char_3.f90: New test.
* gfortran.dg/maxval_char_4.f90: New test.
* gfortran.dg/minval_char_1.f90: New test.
* gfortran.dg/minval_char_2.f90: New test.
* gfortran.dg/minval_char_3.f90: New test.
* gfortran.dg/minval_char_4.f90: New test.
From-SVN: r255367
Diffstat (limited to 'libgfortran')
| -rw-r--r-- | libgfortran/ChangeLog | 23 | ||||
| -rw-r--r-- | libgfortran/Makefile.am | 33 | ||||
| -rw-r--r-- | libgfortran/Makefile.in | 139 | ||||
| -rw-r--r-- | libgfortran/generated/maxval0_s1.c | 258 | ||||
| -rw-r--r-- | libgfortran/generated/maxval0_s4.c | 258 | ||||
| -rw-r--r-- | libgfortran/generated/maxval1_s1.c | 560 | ||||
| -rw-r--r-- | libgfortran/generated/maxval1_s4.c | 560 | ||||
| -rw-r--r-- | libgfortran/generated/minval0_s1.c | 258 | ||||
| -rw-r--r-- | libgfortran/generated/minval0_s4.c | 258 | ||||
| -rw-r--r-- | libgfortran/generated/minval1_s1.c | 560 | ||||
| -rw-r--r-- | libgfortran/generated/minval1_s4.c | 560 | ||||
| -rw-r--r-- | libgfortran/gfortran.map | 24 | ||||
| -rw-r--r-- | libgfortran/m4/iforeach-s2.m4 | 222 | ||||
| -rw-r--r-- | libgfortran/m4/ifunction-s2.m4 | 542 | ||||
| -rw-r--r-- | libgfortran/m4/iparm.m4 | 1 | ||||
| -rw-r--r-- | libgfortran/m4/maxval0s.m4 | 58 | ||||
| -rw-r--r-- | libgfortran/m4/maxval1s.m4 | 61 | ||||
| -rw-r--r-- | libgfortran/m4/minval0s.m4 | 58 | ||||
| -rw-r--r-- | libgfortran/m4/minval1s.m4 | 61 |
19 files changed, 4474 insertions, 20 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 2e768866713..55867f02a2d 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,26 @@ +2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/36313 + * Makefile.am: Add new files for character-valued + maxval and minval. + * Makefile.in: Regenerated. + * gfortran.map: Add new functions. + * m4/iforeach-s2.m4: New file. + * m4/ifunction-s2.m4: New file. + * m4/iparm.m4: Add intitval for minval and maxval. + * m4/maxval0s.m4: New file. + * m4/maxval1s.m4: New file. + * m4/minval0s.m4: New file. + * m4/minval1s.m4: New file. + * generated/maxval0_s1.c: New file. + * generated/maxval0_s4.c: New file. + * generated/maxval1_s1.c: New file. + * generated/maxval1_s4.c: New file. + * generated/minval0_s1.c: New file. + * generated/minval0_s4.c: New file. + * generated/minval1_s1.c: New file. + * generated/minval1_s4.c: New file. + 2017-12-03 Jerry DeLisle <jvdelisle@gcc.gnu.org> Dominique d'Humieres <dominiq@lps.ens.fr> diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index b88d62b6857..bf9dce40593 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -357,6 +357,14 @@ $(srcdir)/generated/maxval_r8.c \ $(srcdir)/generated/maxval_r10.c \ $(srcdir)/generated/maxval_r16.c +i_maxval0s_c=\ +$(srcdir)/generated/maxval0_s1.c \ +$(srcdir)/generated/maxval0_s4.c + +i_maxval1s_c=\ +$(srcdir)/generated/maxval1_s1.c \ +$(srcdir)/generated/maxval1_s4.c + i_minloc0_c= \ $(srcdir)/generated/minloc0_4_i1.c \ $(srcdir)/generated/minloc0_8_i1.c \ @@ -450,6 +458,14 @@ $(srcdir)/generated/minval_r8.c \ $(srcdir)/generated/minval_r10.c \ $(srcdir)/generated/minval_r16.c +i_minval0s_c=\ +$(srcdir)/generated/minval0_s1.c \ +$(srcdir)/generated/minval0_s4.c + +i_minval1s_c=\ +$(srcdir)/generated/minval1_s1.c \ +$(srcdir)/generated/minval1_s4.c + i_norm2_c= \ $(srcdir)/generated/norm2_r4.c \ $(srcdir)/generated/norm2_r8.c \ @@ -748,7 +764,8 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \ $(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \ - $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) + $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \ + $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) # Machine generated specifics gfor_built_specific_src= \ @@ -973,6 +990,8 @@ I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4 I_M4_DEPS2=$(I_M4_DEPS) m4/ifunction_logical.m4 I_M4_DEPS3=$(I_M4_DEPS) m4/iforeach-s.m4 I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4 +I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4 +I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4 kinds.h: $(srcdir)/mk-kinds-h.sh $(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@ @@ -1039,6 +1058,12 @@ $(i_maxloc2s_c): m4/maxloc2s.m4 $(I_M4_DEPS) $(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@ +$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5) + $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@ + +$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6) + $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@ + $(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0) $(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@ @@ -1057,6 +1082,12 @@ $(i_minloc2s_c): m4/minloc2s.m4 $(I_M4_DEPS) $(i_minval_c): m4/minval.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@ +$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5) + $(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@ + +$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6) + $(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@ + $(i_product_c): m4/product.m4 $(I_M4_DEPS1) $(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 02634988782..03c3968732a 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -329,7 +329,11 @@ am__objects_41 = maxloc2_4_s1.lo maxloc2_4_s4.lo maxloc2_8_s1.lo \ maxloc2_8_s4.lo maxloc2_16_s1.lo maxloc2_16_s4.lo am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo minloc2_8_s1.lo \ minloc2_8_s4.lo minloc2_16_s1.lo minloc2_16_s4.lo -am__objects_43 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \ +am__objects_43 = maxval0_s1.lo maxval0_s4.lo +am__objects_44 = minval0_s1.lo minval0_s4.lo +am__objects_45 = maxval1_s1.lo maxval1_s4.lo +am__objects_46 = minval1_s1.lo minval1_s4.lo +am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \ $(am__objects_7) $(am__objects_8) $(am__objects_9) \ $(am__objects_10) $(am__objects_11) $(am__objects_12) \ $(am__objects_13) $(am__objects_14) $(am__objects_15) \ @@ -341,14 +345,16 @@ am__objects_43 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \ $(am__objects_31) $(am__objects_32) $(am__objects_33) \ $(am__objects_34) $(am__objects_35) $(am__objects_36) \ $(am__objects_37) $(am__objects_38) $(am__objects_39) \ - $(am__objects_40) $(am__objects_41) $(am__objects_42) -@LIBGFOR_MINIMAL_FALSE@am__objects_44 = close.lo file_pos.lo format.lo \ + $(am__objects_40) $(am__objects_41) $(am__objects_42) \ + $(am__objects_43) $(am__objects_44) $(am__objects_45) \ + $(am__objects_46) +@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \ @LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \ @LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \ @LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \ @LIBGFOR_MINIMAL_FALSE@ fbuf.lo -am__objects_45 = size_from_kind.lo $(am__objects_44) -@LIBGFOR_MINIMAL_FALSE@am__objects_46 = access.lo c99_functions.lo \ +am__objects_49 = size_from_kind.lo $(am__objects_48) +@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \ @LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \ @LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \ @LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \ @@ -358,19 +364,19 @@ am__objects_45 = size_from_kind.lo $(am__objects_44) @LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \ @LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \ @LIBGFOR_MINIMAL_FALSE@ unlink.lo -@IEEE_SUPPORT_TRUE@am__objects_47 = ieee_helper.lo -am__objects_48 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \ +@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo +am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \ eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \ ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \ selected_char_kind.lo size.lo spread_generic.lo \ string_intrinsics.lo rand.lo random.lo reshape_generic.lo \ reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \ - $(am__objects_46) $(am__objects_47) -@IEEE_SUPPORT_TRUE@am__objects_49 = ieee_arithmetic.lo \ + $(am__objects_50) $(am__objects_51) +@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \ @IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo -am__objects_50 = -am__objects_51 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ +am__objects_54 = +am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ _abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \ _abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \ _aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \ @@ -394,19 +400,19 @@ am__objects_51 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ _conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \ _aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \ _anint_r8.lo _anint_r10.lo _anint_r16.lo -am__objects_52 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ +am__objects_56 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ _sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \ _dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \ _atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \ _mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \ _mod_r10.lo _mod_r16.lo -am__objects_53 = misc_specifics.lo -am__objects_54 = $(am__objects_51) $(am__objects_52) $(am__objects_53) \ +am__objects_57 = misc_specifics.lo +am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \ dprod_r8.lo f2c_specifics.lo -am__objects_55 = $(am__objects_3) $(am__objects_43) $(am__objects_45) \ - $(am__objects_48) $(am__objects_49) $(am__objects_50) \ - $(am__objects_54) -@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_55) +am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \ + $(am__objects_52) $(am__objects_53) $(am__objects_54) \ + $(am__objects_58) +@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59) @onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) DEFAULT_INCLUDES = -I.@am__isrc@ @@ -810,6 +816,14 @@ $(srcdir)/generated/maxval_r8.c \ $(srcdir)/generated/maxval_r10.c \ $(srcdir)/generated/maxval_r16.c +i_maxval0s_c = \ +$(srcdir)/generated/maxval0_s1.c \ +$(srcdir)/generated/maxval0_s4.c + +i_maxval1s_c = \ +$(srcdir)/generated/maxval1_s1.c \ +$(srcdir)/generated/maxval1_s4.c + i_minloc0_c = \ $(srcdir)/generated/minloc0_4_i1.c \ $(srcdir)/generated/minloc0_8_i1.c \ @@ -903,6 +917,14 @@ $(srcdir)/generated/minval_r8.c \ $(srcdir)/generated/minval_r10.c \ $(srcdir)/generated/minval_r16.c +i_minval0s_c = \ +$(srcdir)/generated/minval0_s1.c \ +$(srcdir)/generated/minval0_s4.c + +i_minval1s_c = \ +$(srcdir)/generated/minval1_s1.c \ +$(srcdir)/generated/minval1_s4.c + i_norm2_c = \ $(srcdir)/generated/norm2_r4.c \ $(srcdir)/generated/norm2_r8.c \ @@ -1201,7 +1223,8 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \ $(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \ - $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) + $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \ + $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) # Machine generated specifics @@ -1379,6 +1402,8 @@ I_M4_DEPS1 = $(I_M4_DEPS) m4/ifunction.m4 I_M4_DEPS2 = $(I_M4_DEPS) m4/ifunction_logical.m4 I_M4_DEPS3 = $(I_M4_DEPS) m4/iforeach-s.m4 I_M4_DEPS4 = $(I_M4_DEPS) m4/ifunction-s.m4 +I_M4_DEPS5 = $(I_M4_DEPS) m4/iforeach-s2.m4 +I_M4_DEPS6 = $(I_M4_DEPS) m4/ifunction-s2.m4 EXTRA_DIST = $(m4_files) all: $(BUILT_SOURCES) config.h $(MAKE) $(AM_MAKEFLAGS) all-am @@ -1784,6 +1809,10 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_4_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i2.Plo@am__quote@ @@ -1867,6 +1896,10 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_4_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i2.Plo@am__quote@ @@ -5612,6 +5645,62 @@ minloc2_16_s4.lo: $(srcdir)/generated/minloc2_16_s4.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minloc2_16_s4.lo `test -f '$(srcdir)/generated/minloc2_16_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minloc2_16_s4.c +maxval0_s1.lo: $(srcdir)/generated/maxval0_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s1.lo -MD -MP -MF $(DEPDIR)/maxval0_s1.Tpo -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s1.Tpo $(DEPDIR)/maxval0_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s1.c' object='maxval0_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c + +maxval0_s4.lo: $(srcdir)/generated/maxval0_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s4.lo -MD -MP -MF $(DEPDIR)/maxval0_s4.Tpo -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s4.Tpo $(DEPDIR)/maxval0_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s4.c' object='maxval0_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c + +minval0_s1.lo: $(srcdir)/generated/minval0_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s1.lo -MD -MP -MF $(DEPDIR)/minval0_s1.Tpo -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s1.Tpo $(DEPDIR)/minval0_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s1.c' object='minval0_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c + +minval0_s4.lo: $(srcdir)/generated/minval0_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s4.lo -MD -MP -MF $(DEPDIR)/minval0_s4.Tpo -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s4.Tpo $(DEPDIR)/minval0_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s4.c' object='minval0_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c + +maxval1_s1.lo: $(srcdir)/generated/maxval1_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s1.lo -MD -MP -MF $(DEPDIR)/maxval1_s1.Tpo -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s1.Tpo $(DEPDIR)/maxval1_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s1.c' object='maxval1_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c + +maxval1_s4.lo: $(srcdir)/generated/maxval1_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s4.lo -MD -MP -MF $(DEPDIR)/maxval1_s4.Tpo -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s4.Tpo $(DEPDIR)/maxval1_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s4.c' object='maxval1_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c + +minval1_s1.lo: $(srcdir)/generated/minval1_s1.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s1.lo -MD -MP -MF $(DEPDIR)/minval1_s1.Tpo -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s1.Tpo $(DEPDIR)/minval1_s1.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s1.c' object='minval1_s1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c + +minval1_s4.lo: $(srcdir)/generated/minval1_s4.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s4.lo -MD -MP -MF $(DEPDIR)/minval1_s4.Tpo -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s4.Tpo $(DEPDIR)/minval1_s4.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s4.c' object='minval1_s4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c + size_from_kind.lo: io/size_from_kind.c @am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT size_from_kind.lo -MD -MP -MF $(DEPDIR)/size_from_kind.Tpo -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo @@ -6507,6 +6596,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h @MAINTAINER_MODE_TRUE@$(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@ +@MAINTAINER_MODE_TRUE@$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@ + +@MAINTAINER_MODE_TRUE@$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@ + @MAINTAINER_MODE_TRUE@$(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@ @@ -6525,6 +6620,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h @MAINTAINER_MODE_TRUE@$(i_minval_c): m4/minval.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@ +@MAINTAINER_MODE_TRUE@$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@ + +@MAINTAINER_MODE_TRUE@$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@ + @MAINTAINER_MODE_TRUE@$(i_product_c): m4/product.m4 $(I_M4_DEPS1) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@ diff --git a/libgfortran/generated/maxval0_s1.c b/libgfortran/generated/maxval0_s1.c new file mode 100644 index 00000000000..4ed9258b205 --- /dev/null +++ b/libgfortran/generated/maxval0_s1.c @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h> + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 0 + +extern void maxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, gfc_charlen_type); +export_proto(maxval0_s1); + +void +maxval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s1 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_1 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mmaxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mmaxval0_s1); + +void +mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_1 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void smaxval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(smaxval0_s1); + +void +smaxval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + maxval0_s1 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif diff --git a/libgfortran/generated/maxval0_s4.c b/libgfortran/generated/maxval0_s4.c new file mode 100644 index 00000000000..689b170acb1 --- /dev/null +++ b/libgfortran/generated/maxval0_s4.c @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h> + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 0 + +extern void maxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, gfc_charlen_type); +export_proto(maxval0_s4); + +void +maxval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s4 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_4 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mmaxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mmaxval0_s4); + +void +mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_4 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void smaxval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(smaxval0_s4); + +void +smaxval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + maxval0_s4 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif diff --git a/libgfortran/generated/maxval1_s1.c b/libgfortran/generated/maxval1_s1.c new file mode 100644 index 00000000000..b9da5a388b7 --- /dev/null +++ b/libgfortran/generated/maxval1_s1.c @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void maxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(maxval1_s1); + +void +maxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + src = base; + { + + const GFC_INTEGER_1 *retval; + retval = base; + if (len <= 0) + memset (dest, 0, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mmaxval1_s1); + +void +mmaxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_1 *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void smaxval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(smaxval1_s1); + +void +smaxval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval1_s1 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 0, sizeof (*dest) * string_len); + 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/maxval1_s4.c b/libgfortran/generated/maxval1_s4.c new file mode 100644 index 00000000000..e98ea71c272 --- /dev/null +++ b/libgfortran/generated/maxval1_s4.c @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void maxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(maxval1_s4); + +void +maxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + src = base; + { + + const GFC_INTEGER_4 *retval; + retval = base; + if (len <= 0) + memset (dest, 0, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mmaxval1_s4); + +void +mmaxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_4 *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void smaxval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(smaxval1_s4); + +void +smaxval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval1_s4 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 0, sizeof (*dest) * string_len); + 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/minval0_s1.c b/libgfortran/generated/minval0_s1.c new file mode 100644 index 00000000000..311c9bda926 --- /dev/null +++ b/libgfortran/generated/minval0_s1.c @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h> + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 255 + +extern void minval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, gfc_charlen_type); +export_proto(minval0_s1); + +void +minval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s1 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_1 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mminval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mminval0_s1); + +void +mminval0_s1 (GFC_INTEGER_1 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_1 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void sminval0_s1 (GFC_INTEGER_1 * restrict, + gfc_charlen_type, + gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(sminval0_s1); + +void +sminval0_s1 (GFC_INTEGER_1 * restrict ret, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + minval0_s1 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif diff --git a/libgfortran/generated/minval0_s4.c b/libgfortran/generated/minval0_s4.c new file mode 100644 index 00000000000..a2c44afaaf0 --- /dev/null +++ b/libgfortran/generated/minval0_s4.c @@ -0,0 +1,258 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h> + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 255 + +extern void minval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, gfc_charlen_type); +export_proto(minval0_s4); + +void +minval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, + gfc_array_s4 * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { + + const GFC_INTEGER_4 *retval; + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void mminval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(mminval0_s4); + +void +mminval0_s4 (GFC_INTEGER_4 * const restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { + + const GFC_INTEGER_4 *retval; + + retval = ret; + + while (base) + { + do + { + /* Implementation start. */ + + if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +} + + +extern void sminval0_s4 (GFC_INTEGER_4 * restrict, + gfc_charlen_type, + gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(sminval0_s4); + +void +sminval0_s4 (GFC_INTEGER_4 * restrict ret, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + minval0_s4 (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +} + +#endif diff --git a/libgfortran/generated/minval1_s1.c b/libgfortran/generated/minval1_s1.c new file mode 100644 index 00000000000..02eb41eea0a --- /dev/null +++ b/libgfortran/generated/minval1_s1.c @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + +#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_1) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void minval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(minval1_s1); + +void +minval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + src = base; + { + + const GFC_INTEGER_1 *retval; + retval = base; + if (len <= 0) + memset (dest, 255, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mminval1_s1); + +void +mminval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_1 *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void sminval1_s1 (gfc_array_s1 * const restrict, + gfc_charlen_type, gfc_array_s1 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(sminval1_s1); + +void +sminval1_s1 (gfc_array_s1 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval1_s1 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 255, sizeof (*dest) * string_len); + 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/minval1_s4.c b/libgfortran/generated/minval1_s4.c new file mode 100644 index 00000000000..b6a794ea4a4 --- /dev/null +++ b/libgfortran/generated/minval1_s4.c @@ -0,0 +1,560 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n) +{ + if (sizeof (GFC_INTEGER_4) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void minval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(minval1_s4); + +void +minval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + src = base; + { + + const GFC_INTEGER_4 *retval; + retval = base; + if (len <= 0) + memset (dest, 255, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + } + + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(mminval1_s4); + +void +mminval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { + + const GFC_INTEGER_4 *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + + } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +void sminval1_s4 (gfc_array_s4 * const restrict, + gfc_charlen_type, gfc_array_s4 * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(sminval1_s4); + +void +sminval1_s4 (gfc_array_s4 * const restrict retarray, + gfc_charlen_type xlen, gfc_array_s4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval1_s4 (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINVAL intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, 255, sizeof (*dest) * string_len); + 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 4f8b4f3e298..d3403af0dac 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -420,6 +420,10 @@ GFORTRAN_8 { _gfortran_maxloc2_4_s4; _gfortran_maxloc2_8_s1; _gfortran_maxloc2_8_s4; + _gfortran_maxval0_s1; + _gfortran_maxval0_s4; + _gfortran_maxval1_s1; + _gfortran_maxval1_s4; _gfortran_maxval_i16; _gfortran_maxval_i1; _gfortran_maxval_i2; @@ -513,6 +517,10 @@ GFORTRAN_8 { _gfortran_minloc2_4_s4; _gfortran_minloc2_8_s1; _gfortran_minloc2_8_s4; + _gfortran_minval0_s1; + _gfortran_minval0_s4; + _gfortran_minval1_s1; + _gfortran_minval1_s4; _gfortran_minval_i16; _gfortran_minval_i1; _gfortran_minval_i2; @@ -599,6 +607,10 @@ GFORTRAN_8 { _gfortran_mmaxloc2_4_s4; _gfortran_mmaxloc2_8_s1; _gfortran_mmaxloc2_8_s4; + _gfortran_mmaxval0_s1; + _gfortran_mmaxval0_s4; + _gfortran_mmaxval1_s1; + _gfortran_mmaxval1_s4; _gfortran_mmaxval_i16; _gfortran_mmaxval_i1; _gfortran_mmaxval_i2; @@ -680,6 +692,10 @@ GFORTRAN_8 { _gfortran_mminloc2_4_s4; _gfortran_mminloc2_8_s1; _gfortran_mminloc2_8_s4; + _gfortran_mminval0_s1; + _gfortran_mminval0_s4; + _gfortran_mminval1_s1; + _gfortran_mminval1_s4; _gfortran_mminval_i16; _gfortran_mminval_i1; _gfortran_mminval_i2; @@ -927,6 +943,10 @@ GFORTRAN_8 { _gfortran_smaxloc2_4_s4; _gfortran_smaxloc2_8_s1; _gfortran_smaxloc2_8_s4; + _gfortran_smaxval0_s1; + _gfortran_smaxval0_s4; + _gfortran_smaxval1_s1; + _gfortran_smaxval1_s4; _gfortran_smaxval_i16; _gfortran_smaxval_i1; _gfortran_smaxval_i2; @@ -1008,6 +1028,10 @@ GFORTRAN_8 { _gfortran_sminloc2_4_s4; _gfortran_sminloc2_8_s1; _gfortran_sminloc2_8_s4; + _gfortran_sminval0_s1; + _gfortran_sminval0_s4; + _gfortran_sminval1_s1; + _gfortran_sminval1_s4; _gfortran_sminval_i16; _gfortran_sminval_i1; _gfortran_sminval_i2; diff --git a/libgfortran/m4/iforeach-s2.m4 b/libgfortran/m4/iforeach-s2.m4 new file mode 100644 index 00000000000..19d016f7c65 --- /dev/null +++ b/libgfortran/m4/iforeach-s2.m4 @@ -0,0 +1,222 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +define(START_FOREACH_FUNCTION, +`static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 'initval` + +extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret, + gfc_charlen_type xlen, + 'atype` * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const 'atype_name` *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { +')dnl +define(START_FOREACH_BLOCK, +` while (base) + { + do + { + /* Implementation start. */ +')dnl +define(FINISH_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(START_MASKED_FOREACH_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const atype_name *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { +')dnl +define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl +define(FINISH_MASKED_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(FOREACH_FUNCTION, +`START_FOREACH_FUNCTION +$1 +START_FOREACH_BLOCK +$2 +FINISH_FOREACH_FUNCTION')dnl +define(MASKED_FOREACH_FUNCTION, +`START_MASKED_FOREACH_FUNCTION +$1 +START_MASKED_FOREACH_BLOCK +$2 +FINISH_MASKED_FOREACH_FUNCTION')dnl +define(SCALAR_FOREACH_FUNCTION, +` +extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + name`'rtype_qual`_'atype_code (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +}')dnl diff --git a/libgfortran/m4/ifunction-s2.m4 b/libgfortran/m4/ifunction-s2.m4 new file mode 100644 index 00000000000..4eb09084dde --- /dev/null +++ b/libgfortran/m4/ifunction-s2.m4 @@ -0,0 +1,542 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +dnl +dnl Pass the implementation for a single section as the parameter to +dnl {MASK_}ARRAY_FUNCTION. +dnl The variables base, delta, and len describe the input section. +dnl For masked section the mask is described by mbase and mdelta. +dnl These should not be modified. The result should be stored in *dest. +dnl The names count, extent, sstride, dstride, base, dest, rank, dim +dnl retarray, array, pdim and mstride should not be used. +dnl The variable n is declared as index_type and may be used. +dnl Other variable declarations may be placed at the start of the code, +dnl The types of the array parameter and the return value are +dnl atype_name and rtype_name respectively. +dnl Execution should be allowed to continue to the end of the block. +dnl You should not return or break from the inner loop of the implementation. +dnl Care should also be taken to avoid using the names defined in iparm.m4 +define(START_ARRAY_FUNCTION, +`#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const atype_name * restrict base; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + 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 (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const atype_name * restrict src; + src = base; + { +')dnl +define(START_ARRAY_BLOCK, +` if (len <= 0) + memset (dest, '$1`, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { +')dnl +define(FINISH_ARRAY_FUNCTION, +` } + '$1` + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(START_MASKED_ARRAY_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + const atype_name * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in u_name intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "u_name"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const atype_name * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { +')dnl +define(START_MASKED_ARRAY_BLOCK, +` for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { +')dnl +define(FINISH_MASKED_ARRAY_FUNCTION, +` } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(SCALAR_ARRAY_FUNCTION, +` +void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + } + 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 (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, '$1`, sizeof (*dest) * string_len); + 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($1) +$2 +START_ARRAY_BLOCK($1) +$3 +FINISH_ARRAY_FUNCTION($4)')dnl +define(MASKED_ARRAY_FUNCTION, +`START_MASKED_ARRAY_FUNCTION +$2 +START_MASKED_ARRAY_BLOCK +$3 +FINISH_MASKED_ARRAY_FUNCTION')dnl diff --git a/libgfortran/m4/iparm.m4 b/libgfortran/m4/iparm.m4 index 4bf2a3010cf..a5596c98a16 100644 --- a/libgfortran/m4/iparm.m4 +++ b/libgfortran/m4/iparm.m4 @@ -35,3 +35,4 @@ define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl +define(initval,ifelse(index(name,`maxval'),0,0,index(name,`minval'),0,255))dnl diff --git a/libgfortran/m4/maxval0s.m4 b/libgfortran/m4/maxval0s.m4 new file mode 100644 index 00000000000..eeb4d7b27e2 --- /dev/null +++ b/libgfortran/m4/maxval0s.m4 @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h>' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif diff --git a/libgfortran/m4/maxval1s.m4 b/libgfortran/m4/maxval1s.m4 new file mode 100644 index 00000000000..edf0ef1ba04 --- /dev/null +++ b/libgfortran/m4/maxval1s.m4 @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(0, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(0, +` const atype_name *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(0) + +#endif diff --git a/libgfortran/m4/minval0s.m4 b/libgfortran/m4/minval0s.m4 new file mode 100644 index 00000000000..0bcf543503a --- /dev/null +++ b/libgfortran/m4/minval0s.m4 @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h>' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif diff --git a/libgfortran/m4/minval1s.m4 b/libgfortran/m4/minval1s.m4 new file mode 100644 index 00000000000..3f52bd9bdab --- /dev/null +++ b/libgfortran/m4/minval1s.m4 @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(255, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(255, +` const atype_name *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(255) + +#endif |