From 3ef2513a1d3a2497773f9aa37ac1242e88df8652 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Fri, 21 Mar 2008 14:37:03 +0000 Subject: re PR libfortran/32972 (performance of pack/unpack) 2008-03-21 Thomas Koenig PR libfortran/32972 * Makefile.am: Add new variable, i_pack_c, containing pack_i1.c, pack_i2.c, pack_i4.c, pack_i8.c, pack_i16.c, pack_r4.c, pack_r8.c, pack_r10.c, pack_r16.c, pack_c4.c, pack_c8.c, pack_c10.c, pack_c16.c. Add m4/pack.m4 to m4_files. Add i_pack_c to gfor_built_src. Add rule to generate i_pack_c from m4/pack.m4. * Makefile.in: Regenerated. * libgfortran.h: Add prototypes for pack_i1, pack_i2, pack_i4, pack_i8, pack_i16, pack_r4, pack_r8, pack_c4, pack_c8, pack_c10, pack_c16. * intrinsics/pack_generic.c: Add calls to specific pack functions. * m4/pack.m4: New file. * generated/pack_i1.c: New file. * generated/pack_i2.c: New file. * generated/pack_i4.c: New file. * generated/pack_i8.c: New file. * generated/pack_i16.c: New file. * generated/pack_r4.c: New file. * generated/pack_r8.c: New file. * generated/pack_r10.c: New file. * generated/pack_r16.c: New file. * generated/pack_c4.c: New file. * generated/pack_c8.c: New file. * generated/pack_c10.c: New file. * generated/pack_c16.c: New file. 2008-03-21 Thomas Koenig PR libfortran/32972 * internal_pack_1.f90: New test case. * internal_pack_2.f90: New test case. * internal_pack_3.f90: New test case. From-SVN: r133427 --- gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 | 65 ++++++ gcc/testsuite/gfortran.dg/intrinsic_pack_2.f90 | 20 ++ gcc/testsuite/gfortran.dg/intrinsic_pack_3.f90 | 20 ++ libgfortran/ChangeLog | 31 +++ libgfortran/Makefile.am | 22 +- libgfortran/Makefile.in | 162 +++++++++++-- libgfortran/generated/pack_c10.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_c16.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_c4.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_c8.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_i1.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_i16.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_i2.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_i4.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_i8.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_r10.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_r16.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_r4.c | 310 ++++++++++++++++++++++++ libgfortran/generated/pack_r8.c | 310 ++++++++++++++++++++++++ libgfortran/intrinsics/pack_generic.c | 97 +++++++- libgfortran/libgfortran.h | 64 +++++ libgfortran/m4/pack.m4 | 312 +++++++++++++++++++++++++ 23 files changed, 4812 insertions(+), 18 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_pack_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_pack_3.f90 create mode 100644 libgfortran/generated/pack_c10.c create mode 100644 libgfortran/generated/pack_c16.c create mode 100644 libgfortran/generated/pack_c4.c create mode 100644 libgfortran/generated/pack_c8.c create mode 100644 libgfortran/generated/pack_i1.c create mode 100644 libgfortran/generated/pack_i16.c create mode 100644 libgfortran/generated/pack_i2.c create mode 100644 libgfortran/generated/pack_i4.c create mode 100644 libgfortran/generated/pack_i8.c create mode 100644 libgfortran/generated/pack_r10.c create mode 100644 libgfortran/generated/pack_r16.c create mode 100644 libgfortran/generated/pack_r4.c create mode 100644 libgfortran/generated/pack_r8.c create mode 100644 libgfortran/m4/pack.m4 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index baa2a2c..ad3e1ab 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2008-03-21 Thomas Koenig + + PR libfortran/32972 + * internal_pack_1.f90: New test case. + * internal_pack_2.f90: New test case. + * internal_pack_3.f90: New test case. + 2008-03-21 Olivier Hainque * gnat.dg/empty_vector_length.adb: New testcase. diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 new file mode 100644 index 0000000..580d776 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer :: i + real(kind=4), dimension(3,3) :: r4 + real(kind=4), dimension(9) :: vr4 + real(kind=4), dimension(9) :: rr4 + real(kind=8), dimension(3,3) :: r8 + real(kind=8), dimension(9) :: vr8 + real(kind=8), dimension(9) :: rr8 + integer(kind=1), dimension(3,3) :: i1 + integer(kind=1), dimension(9) :: vi1 + integer(kind=1), dimension(9) :: ri1 + integer(kind=2), dimension(3,3) :: i2 + integer(kind=2), dimension(9) :: vi2 + integer(kind=2), dimension(9) :: ri2 + integer(kind=4), dimension(3,3) :: i4 + integer(kind=4), dimension(9) :: vi4 + integer(kind=4), dimension(9) :: ri4 + integer(kind=8), dimension(3,3) :: i8 + integer(kind=8), dimension(9) :: vi8 + integer(kind=8), dimension(9) :: ri8 + + vr4 = (/(i+10,i=1,9)/) + r4 = reshape((/1.0_4, -3.0_4, 2.1_4, -4.21_4, 1.2_4, 0.98_4, -1.2_4, & + & -7.1_4, -9.9_4, 0.3_4 /), shape(r4)) + rr4 = pack(r4,r4>0,vr4) + if (any(rr4 /= (/ 1.0_4, 2.1_4, 1.2_4, 0.98_4, 15._4, 16._4, 17._4, & + & 18._4, 19._4 /))) call abort + + vr8 = (/(i+10,i=1,9)/) + r8 = reshape((/1.0_8, -3.0_8, 2.1_8, -4.21_8, 1.2_8, 0.98_8, -1.2_8, & + & -7.1_8, -9.9_8, 0.3_8 /), shape(r8)) + rr8 = pack(r8,r8>0,vr8) + if (any(rr8 /= (/ 1.0_8, 2.1_8, 1.2_8, 0.98_8, 15._8, 16._8, 17._8, & + & 18._8, 19._8 /))) call abort + + vi1 = (/(i+10,i=1,9)/) + i1 = reshape((/1_1, -1_1, 2_1, -2_1, 3_1, -3_1, 4_1, -4_1, 5_1/), shape(i1)) + ri1 = pack(i1,i1>0,vi1) + if (any(ri1 /= (/1_1, 2_1, 3_1, 4_1, 5_1, 16_1, 17_1, 18_1, 19_1/))) & + & call abort + + vi2 = (/(i+10,i=1,9)/) + i2 = reshape((/1_2, -1_2, 2_2, -2_2, 3_2, -3_2, 4_2, -4_2, 5_2/), shape(i2)) + ri2 = pack(i2,i2>0,vi2) + if (any(ri2 /= (/1_2, 2_2, 3_2, 4_2, 5_2, 16_2, 17_2, 18_2, 19_2/))) & + & call abort + + vi4 = (/(i+10,i=1,9)/) + i4 = reshape((/1_4, -1_4, 2_4, -2_4, 3_4, -3_4, 4_4, -4_4, 5_4/), shape(i4)) + ri4 = pack(i4,i4>0,vi4) + if (any(ri4 /= (/1_4, 2_4, 3_4, 4_4, 5_4, 16_4, 17_4, 18_4, 19_4/))) & + & call abort + + vi8 = (/(i+10,i=1,9)/) + i8 = reshape((/1_8, -1_8, 2_8, -2_8, 3_8, -3_8, 4_8, -4_8, 5_8/), shape(i8)) + ri8 = pack(i8,i8>0,vi8) + if (any(ri8 /= (/1_8, 2_8, 3_8, 4_8, 5_8, 16_8, 17_8, 18_8, 19_8/))) & + & call abort + + +end program main diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_2.f90 new file mode 100644 index 0000000..aba93d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + integer :: i + real(kind=k), dimension(3,3) :: rk + real(kind=k), dimension(9) :: vrk + real(kind=k), dimension(9) :: rrk + + vrk = (/(i+10,i=1,9)/) + rk = reshape((/1.0_k, -3.0_k, 2.1_k, -4.21_k, 1.2_k, 0.98_k, -1.2_k, & + & -7.1_k, -9.9_k, 0.3_k /), shape(rk)) + rrk = pack(rk,rk>0,vrk) + if (any(rrk /= (/ 1.0_k, 2.1_k, 1.2_k, 0.98_k, 15._k, 16._k, 17._k, & + & 18._k, 19._k /))) call abort + +end program main diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_3.f90 new file mode 100644 index 0000000..d559e91 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + integer :: i + integer(kind=k), dimension(3,3) :: ik + integer(kind=k), dimension(9) :: vik + integer(kind=k), dimension(9) :: rik + + vik = (/(i+10,i=1,9)/) + ik = reshape((/1_k, -1_k, 2_k, -2_k, 3_k, -3_k, 4_k, -4_k, 5_k/), shape(ik)) + rik = pack(ik,ik>0,vik) + if (any(rik /= (/1_k, 2_k, 3_k, 4_k, 5_k, 16_k, 17_k, 18_k, 19_k/))) & + & call abort + + +end program main diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index ee0aae8..b2efca9 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,34 @@ +2008-03-21 Thomas Koenig + + PR libfortran/32972 + * Makefile.am: Add new variable, i_pack_c, containing + pack_i1.c, pack_i2.c, pack_i4.c, pack_i8.c, pack_i16.c, + pack_r4.c, pack_r8.c, pack_r10.c, pack_r16.c, pack_c4.c, + pack_c8.c, pack_c10.c, pack_c16.c. + Add m4/pack.m4 to m4_files. + Add i_pack_c to gfor_built_src. + Add rule to generate i_pack_c from m4/pack.m4. + * Makefile.in: Regenerated. + * libgfortran.h: Add prototypes for pack_i1, pack_i2, pack_i4, + pack_i8, pack_i16, pack_r4, pack_r8, pack_c4, pack_c8, + pack_c10, pack_c16. + * intrinsics/pack_generic.c: Add calls to specific + pack functions. + * m4/pack.m4: New file. + * generated/pack_i1.c: New file. + * generated/pack_i2.c: New file. + * generated/pack_i4.c: New file. + * generated/pack_i8.c: New file. + * generated/pack_i16.c: New file. + * generated/pack_r4.c: New file. + * generated/pack_r8.c: New file. + * generated/pack_r10.c: New file. + * generated/pack_r16.c: New file. + * generated/pack_c4.c: New file. + * generated/pack_c8.c: New file. + * generated/pack_c10.c: New file. + * generated/pack_c16.c: New file. + 2008-03-19 Jerry DeLisle PR libfortran/35627 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index bcf9ffa..1706c6a 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -476,6 +476,21 @@ $(srcdir)/generated/pow_c8_i16.c \ $(srcdir)/generated/pow_c10_i16.c \ $(srcdir)/generated/pow_c16_i16.c +i_pack_c = \ +$(srcdir)/generated/pack_i1.c \ +$(srcdir)/generated/pack_i2.c \ +$(srcdir)/generated/pack_i4.c \ +$(srcdir)/generated/pack_i8.c \ +$(srcdir)/generated/pack_i16.c \ +$(srcdir)/generated/pack_r4.c \ +$(srcdir)/generated/pack_r8.c \ +$(srcdir)/generated/pack_r10.c \ +$(srcdir)/generated/pack_r16.c \ +$(srcdir)/generated/pack_c4.c \ +$(srcdir)/generated/pack_c8.c \ +$(srcdir)/generated/pack_c10.c \ +$(srcdir)/generated/pack_c16.c + m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \ m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \ @@ -484,7 +499,7 @@ m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/specific.m4 m4/specific2.m4 m4/head.m4 m4/shape.m4 m4/reshape.m4 \ m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \ m4/fraction.m4 m4/nearest.m4 m4/set_exponent.m4 m4/pow.m4 \ - m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 + m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 m4/pack.m4 gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \ @@ -492,7 +507,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \ $(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \ $(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \ - $(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) \ + $(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) $(i_pack_c) \ selected_int_kind.inc selected_real_kind.inc kinds.h \ kinds.inc c99_protos.inc fpu-target.h @@ -808,6 +823,9 @@ $(i_set_exponent_c): m4/set_exponent.m4 m4/mtype.m4 $(i_pow_c): m4/pow.m4 $(I_M4_DEPS) $(M4) -Dfile=$@ -I$(srcdir)/m4 pow.m4 > $@ +$(i_pack_c): m4/pack.m4 $(I_M4_DEPS) + $(M4) -Dfile=$@ -I$(srcdir)/m4 pack.m4 > $@ + $(gfor_built_specific_src): m4/specific.m4 m4/head.m4 $(M4) -Dfile=$@ -I$(srcdir)/m4 specific.m4 > $@ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 2d1ce0d..286338b 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -363,7 +363,14 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \ $(srcdir)/generated/spacing_r4.c \ $(srcdir)/generated/spacing_r8.c \ $(srcdir)/generated/spacing_r10.c \ - $(srcdir)/generated/spacing_r16.c selected_int_kind.inc \ + $(srcdir)/generated/spacing_r16.c \ + $(srcdir)/generated/pack_i1.c $(srcdir)/generated/pack_i2.c \ + $(srcdir)/generated/pack_i4.c $(srcdir)/generated/pack_i8.c \ + $(srcdir)/generated/pack_i16.c $(srcdir)/generated/pack_r4.c \ + $(srcdir)/generated/pack_r8.c $(srcdir)/generated/pack_r10.c \ + $(srcdir)/generated/pack_r16.c $(srcdir)/generated/pack_c4.c \ + $(srcdir)/generated/pack_c8.c $(srcdir)/generated/pack_c10.c \ + $(srcdir)/generated/pack_c16.c selected_int_kind.inc \ selected_real_kind.inc kinds.h kinds.inc c99_protos.inc \ fpu-target.h io/close.c io/file_pos.c io/format.c io/inquire.c \ io/intrinsics.c io/list_read.c io/lock.c io/open.c io/read.c \ @@ -633,7 +640,10 @@ am__objects_28 = rrspacing_r4.lo rrspacing_r8.lo rrspacing_r10.lo \ rrspacing_r16.lo am__objects_29 = spacing_r4.lo spacing_r8.lo spacing_r10.lo \ spacing_r16.lo -am__objects_30 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \ +am__objects_30 = pack_i1.lo pack_i2.lo pack_i4.lo pack_i8.lo \ + pack_i16.lo pack_r4.lo pack_r8.lo pack_r10.lo pack_r16.lo \ + pack_c4.lo pack_c8.lo pack_c10.lo pack_c16.lo +am__objects_31 = $(am__objects_2) $(am__objects_3) $(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) \ @@ -642,11 +652,11 @@ am__objects_30 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \ $(am__objects_20) $(am__objects_21) $(am__objects_22) \ $(am__objects_23) $(am__objects_24) $(am__objects_25) \ $(am__objects_26) $(am__objects_27) $(am__objects_28) \ - $(am__objects_29) -am__objects_31 = close.lo file_pos.lo format.lo inquire.lo \ + $(am__objects_29) $(am__objects_30) +am__objects_32 = close.lo file_pos.lo format.lo inquire.lo \ intrinsics.lo list_read.lo lock.lo open.lo read.lo \ size_from_kind.lo transfer.lo unit.lo unix.lo write.lo -am__objects_32 = associated.lo abort.lo access.lo args.lo \ +am__objects_33 = associated.lo abort.lo access.lo args.lo \ c99_functions.lo chdir.lo chmod.lo clock.lo cpu_time.lo \ cshift0.lo ctime.lo date_and_time.lo dtime.lo env.lo \ eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \ @@ -660,8 +670,8 @@ am__objects_32 = associated.lo abort.lo access.lo args.lo \ system_clock.lo time.lo transpose_generic.lo umask.lo \ unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo -am__objects_33 = -am__objects_34 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ +am__objects_34 = +am__objects_35 = _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 \ @@ -685,18 +695,18 @@ am__objects_34 = _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_35 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ +am__objects_36 = _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_36 = misc_specifics.lo -am__objects_37 = $(am__objects_34) $(am__objects_35) $(am__objects_36) \ +am__objects_37 = misc_specifics.lo +am__objects_38 = $(am__objects_35) $(am__objects_36) $(am__objects_37) \ dprod_r8.lo f2c_specifics.lo -am__objects_38 = $(am__objects_1) $(am__objects_30) $(am__objects_31) \ - $(am__objects_32) $(am__objects_33) $(am__objects_37) -@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_38) +am__objects_39 = $(am__objects_1) $(am__objects_31) $(am__objects_32) \ + $(am__objects_33) $(am__objects_34) $(am__objects_38) +@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_39) @onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) libgfortranbegin_la_LIBADD = @@ -1330,6 +1340,21 @@ $(srcdir)/generated/pow_c8_i16.c \ $(srcdir)/generated/pow_c10_i16.c \ $(srcdir)/generated/pow_c16_i16.c +i_pack_c = \ +$(srcdir)/generated/pack_i1.c \ +$(srcdir)/generated/pack_i2.c \ +$(srcdir)/generated/pack_i4.c \ +$(srcdir)/generated/pack_i8.c \ +$(srcdir)/generated/pack_i16.c \ +$(srcdir)/generated/pack_r4.c \ +$(srcdir)/generated/pack_r8.c \ +$(srcdir)/generated/pack_r10.c \ +$(srcdir)/generated/pack_r16.c \ +$(srcdir)/generated/pack_c4.c \ +$(srcdir)/generated/pack_c8.c \ +$(srcdir)/generated/pack_c10.c \ +$(srcdir)/generated/pack_c16.c + m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \ m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \ @@ -1338,7 +1363,7 @@ m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/specific.m4 m4/specific2.m4 m4/head.m4 m4/shape.m4 m4/reshape.m4 \ m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \ m4/fraction.m4 m4/nearest.m4 m4/set_exponent.m4 m4/pow.m4 \ - m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 + m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 m4/pack.m4 gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \ @@ -1346,7 +1371,7 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \ $(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \ $(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \ $(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \ - $(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) \ + $(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) $(i_pack_c) \ selected_int_kind.inc selected_real_kind.inc kinds.h \ kinds.inc c99_protos.inc fpu-target.h @@ -1902,7 +1927,20 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/nearest_r4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/nearest_r8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/open.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_c10.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_c16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_c4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_c8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_generic.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_i1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_i16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_i2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_i4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_r10.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_r16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_r4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pack_r8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pause.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/perror.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/pow_c10_i16.Plo@am__quote@ @@ -4619,6 +4657,97 @@ spacing_r16.lo: $(srcdir)/generated/spacing_r16.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o spacing_r16.lo `test -f '$(srcdir)/generated/spacing_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spacing_r16.c +pack_i1.lo: $(srcdir)/generated/pack_i1.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_i1.lo -MD -MP -MF "$(DEPDIR)/pack_i1.Tpo" -c -o pack_i1.lo `test -f '$(srcdir)/generated/pack_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i1.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_i1.Tpo" "$(DEPDIR)/pack_i1.Plo"; else rm -f "$(DEPDIR)/pack_i1.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_i1.c' object='pack_i1.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_i1.lo `test -f '$(srcdir)/generated/pack_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i1.c + +pack_i2.lo: $(srcdir)/generated/pack_i2.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_i2.lo -MD -MP -MF "$(DEPDIR)/pack_i2.Tpo" -c -o pack_i2.lo `test -f '$(srcdir)/generated/pack_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i2.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_i2.Tpo" "$(DEPDIR)/pack_i2.Plo"; else rm -f "$(DEPDIR)/pack_i2.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_i2.c' object='pack_i2.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_i2.lo `test -f '$(srcdir)/generated/pack_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i2.c + +pack_i4.lo: $(srcdir)/generated/pack_i4.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_i4.lo -MD -MP -MF "$(DEPDIR)/pack_i4.Tpo" -c -o pack_i4.lo `test -f '$(srcdir)/generated/pack_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i4.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_i4.Tpo" "$(DEPDIR)/pack_i4.Plo"; else rm -f "$(DEPDIR)/pack_i4.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_i4.c' object='pack_i4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_i4.lo `test -f '$(srcdir)/generated/pack_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i4.c + +pack_i8.lo: $(srcdir)/generated/pack_i8.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_i8.lo -MD -MP -MF "$(DEPDIR)/pack_i8.Tpo" -c -o pack_i8.lo `test -f '$(srcdir)/generated/pack_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i8.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_i8.Tpo" "$(DEPDIR)/pack_i8.Plo"; else rm -f "$(DEPDIR)/pack_i8.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_i8.c' object='pack_i8.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_i8.lo `test -f '$(srcdir)/generated/pack_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i8.c + +pack_i16.lo: $(srcdir)/generated/pack_i16.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_i16.lo -MD -MP -MF "$(DEPDIR)/pack_i16.Tpo" -c -o pack_i16.lo `test -f '$(srcdir)/generated/pack_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i16.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_i16.Tpo" "$(DEPDIR)/pack_i16.Plo"; else rm -f "$(DEPDIR)/pack_i16.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_i16.c' object='pack_i16.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_i16.lo `test -f '$(srcdir)/generated/pack_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_i16.c + +pack_r4.lo: $(srcdir)/generated/pack_r4.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_r4.lo -MD -MP -MF "$(DEPDIR)/pack_r4.Tpo" -c -o pack_r4.lo `test -f '$(srcdir)/generated/pack_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r4.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_r4.Tpo" "$(DEPDIR)/pack_r4.Plo"; else rm -f "$(DEPDIR)/pack_r4.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_r4.c' object='pack_r4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_r4.lo `test -f '$(srcdir)/generated/pack_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r4.c + +pack_r8.lo: $(srcdir)/generated/pack_r8.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_r8.lo -MD -MP -MF "$(DEPDIR)/pack_r8.Tpo" -c -o pack_r8.lo `test -f '$(srcdir)/generated/pack_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r8.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_r8.Tpo" "$(DEPDIR)/pack_r8.Plo"; else rm -f "$(DEPDIR)/pack_r8.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_r8.c' object='pack_r8.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_r8.lo `test -f '$(srcdir)/generated/pack_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r8.c + +pack_r10.lo: $(srcdir)/generated/pack_r10.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_r10.lo -MD -MP -MF "$(DEPDIR)/pack_r10.Tpo" -c -o pack_r10.lo `test -f '$(srcdir)/generated/pack_r10.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r10.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_r10.Tpo" "$(DEPDIR)/pack_r10.Plo"; else rm -f "$(DEPDIR)/pack_r10.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_r10.c' object='pack_r10.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_r10.lo `test -f '$(srcdir)/generated/pack_r10.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r10.c + +pack_r16.lo: $(srcdir)/generated/pack_r16.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_r16.lo -MD -MP -MF "$(DEPDIR)/pack_r16.Tpo" -c -o pack_r16.lo `test -f '$(srcdir)/generated/pack_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r16.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_r16.Tpo" "$(DEPDIR)/pack_r16.Plo"; else rm -f "$(DEPDIR)/pack_r16.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_r16.c' object='pack_r16.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_r16.lo `test -f '$(srcdir)/generated/pack_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_r16.c + +pack_c4.lo: $(srcdir)/generated/pack_c4.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_c4.lo -MD -MP -MF "$(DEPDIR)/pack_c4.Tpo" -c -o pack_c4.lo `test -f '$(srcdir)/generated/pack_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c4.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_c4.Tpo" "$(DEPDIR)/pack_c4.Plo"; else rm -f "$(DEPDIR)/pack_c4.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_c4.c' object='pack_c4.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_c4.lo `test -f '$(srcdir)/generated/pack_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c4.c + +pack_c8.lo: $(srcdir)/generated/pack_c8.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_c8.lo -MD -MP -MF "$(DEPDIR)/pack_c8.Tpo" -c -o pack_c8.lo `test -f '$(srcdir)/generated/pack_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c8.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_c8.Tpo" "$(DEPDIR)/pack_c8.Plo"; else rm -f "$(DEPDIR)/pack_c8.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_c8.c' object='pack_c8.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_c8.lo `test -f '$(srcdir)/generated/pack_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c8.c + +pack_c10.lo: $(srcdir)/generated/pack_c10.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_c10.lo -MD -MP -MF "$(DEPDIR)/pack_c10.Tpo" -c -o pack_c10.lo `test -f '$(srcdir)/generated/pack_c10.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c10.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_c10.Tpo" "$(DEPDIR)/pack_c10.Plo"; else rm -f "$(DEPDIR)/pack_c10.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_c10.c' object='pack_c10.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_c10.lo `test -f '$(srcdir)/generated/pack_c10.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c10.c + +pack_c16.lo: $(srcdir)/generated/pack_c16.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pack_c16.lo -MD -MP -MF "$(DEPDIR)/pack_c16.Tpo" -c -o pack_c16.lo `test -f '$(srcdir)/generated/pack_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c16.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pack_c16.Tpo" "$(DEPDIR)/pack_c16.Plo"; else rm -f "$(DEPDIR)/pack_c16.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/pack_c16.c' object='pack_c16.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_c16.lo `test -f '$(srcdir)/generated/pack_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/pack_c16.c + close.lo: io/close.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT close.lo -MD -MP -MF "$(DEPDIR)/close.Tpo" -c -o close.lo `test -f 'io/close.c' || echo '$(srcdir)/'`io/close.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/close.Tpo" "$(DEPDIR)/close.Plo"; else rm -f "$(DEPDIR)/close.Tpo"; exit 1; fi @@ -5570,6 +5699,9 @@ fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER) @MAINTAINER_MODE_TRUE@$(i_pow_c): m4/pow.m4 $(I_M4_DEPS) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 pow.m4 > $@ +@MAINTAINER_MODE_TRUE@$(i_pack_c): m4/pack.m4 $(I_M4_DEPS) +@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 pack.m4 > $@ + @MAINTAINER_MODE_TRUE@$(gfor_built_specific_src): m4/specific.m4 m4/head.m4 @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 specific.m4 > $@ diff --git a/libgfortran/generated/pack_c10.c b/libgfortran/generated/pack_c10.c new file mode 100644 index 0000000..c9a0c58 --- /dev/null +++ b/libgfortran/generated/pack_c10.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, + const gfc_array_l1 *mask, const gfc_array_c10 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_10 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_10 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_c16.c b/libgfortran/generated/pack_c16.c new file mode 100644 index 0000000..2996be2 --- /dev/null +++ b/libgfortran/generated/pack_c16.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, + const gfc_array_l1 *mask, const gfc_array_c16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_16 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_c4.c b/libgfortran/generated/pack_c4.c new file mode 100644 index 0000000..ee41c0b --- /dev/null +++ b/libgfortran/generated/pack_c4.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, + const gfc_array_l1 *mask, const gfc_array_c4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_4 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_c8.c b/libgfortran/generated/pack_c8.c new file mode 100644 index 0000000..a129422 --- /dev/null +++ b/libgfortran/generated/pack_c8.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, + const gfc_array_l1 *mask, const gfc_array_c8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_8 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_i1.c b/libgfortran/generated/pack_i1.c new file mode 100644 index 0000000..25d7f56 --- /dev/null +++ b/libgfortran/generated/pack_i1.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, + const gfc_array_l1 *mask, const gfc_array_i1 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_1 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_1 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_i16.c b/libgfortran/generated/pack_i16.c new file mode 100644 index 0000000..35c64ce --- /dev/null +++ b/libgfortran/generated/pack_i16.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, + const gfc_array_l1 *mask, const gfc_array_i16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_16 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_i2.c b/libgfortran/generated/pack_i2.c new file mode 100644 index 0000000..3a42bd3 --- /dev/null +++ b/libgfortran/generated/pack_i2.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, + const gfc_array_l1 *mask, const gfc_array_i2 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_2 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_2 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_i4.c b/libgfortran/generated/pack_i4.c new file mode 100644 index 0000000..28e09f6 --- /dev/null +++ b/libgfortran/generated/pack_i4.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, + const gfc_array_l1 *mask, const gfc_array_i4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_4 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_i8.c b/libgfortran/generated/pack_i8.c new file mode 100644 index 0000000..44fc430 --- /dev/null +++ b/libgfortran/generated/pack_i8.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, + const gfc_array_l1 *mask, const gfc_array_i8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_8 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_r10.c b/libgfortran/generated/pack_r10.c new file mode 100644 index 0000000..72fe254 --- /dev/null +++ b/libgfortran/generated/pack_r10.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, + const gfc_array_l1 *mask, const gfc_array_r10 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_10 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_10 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_10) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_r16.c b/libgfortran/generated/pack_r16.c new file mode 100644 index 0000000..0ced53a --- /dev/null +++ b/libgfortran/generated/pack_r16.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, + const gfc_array_l1 *mask, const gfc_array_r16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_16 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_r4.c b/libgfortran/generated/pack_r4.c new file mode 100644 index 0000000..17172ed --- /dev/null +++ b/libgfortran/generated/pack_r4.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, + const gfc_array_l1 *mask, const gfc_array_r4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_4 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_r8.c b/libgfortran/generated/pack_r8.c new file mode 100644 index 0000000..9d0fb5b --- /dev/null +++ b/libgfortran/generated/pack_r8.c @@ -0,0 +1,310 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, + const gfc_array_l1 *mask, const gfc_array_r8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_8 *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 61b41e5..77760b4 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -313,7 +313,102 @@ void pack (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_l1 *mask, const gfc_array_char *vector) { - pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); + int type; + index_type size; + + type = GFC_DESCRIPTOR_TYPE (array); + size = GFC_DESCRIPTOR_SIZE (array); + + switch(type) + { + case GFC_DTYPE_INTEGER: + case GFC_DTYPE_LOGICAL: + switch(size) + { + case sizeof (GFC_INTEGER_1): + pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, + (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); + return; + + case sizeof (GFC_INTEGER_2): + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; + + case sizeof (GFC_INTEGER_4): + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + + case sizeof (GFC_INTEGER_8): + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case sizeof (GFC_INTEGER_16): + pack_i1 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; +#endif + } + case GFC_DTYPE_REAL: + switch(size) + { + case sizeof (GFC_REAL_4): + pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, + (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); + return; + + case sizeof (GFC_REAL_8): + pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, + (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); + return; + +#ifdef HAVE_GFC_REAL_10 + case sizeof (GFC_REAL_10): + pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, + (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case sizeof (GFC_REAL_16): + pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, + (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); + return; +#endif + } + case GFC_DTYPE_COMPLEX: + switch(size) + { + case sizeof (GFC_COMPLEX_4): + pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, + (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); + return; + + case sizeof (GFC_COMPLEX_8): + pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, + (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case sizeof (GFC_COMPLEX_10): + pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, + (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case sizeof (GFC_REAL_16): + pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, + (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); + return; +#endif + + } + } + pack_internal (ret, array, mask, vector, size); } extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 98af40e..a2b023b 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -710,6 +710,70 @@ extern void internal_unpack_c16 (gfc_array_c16 *, const GFC_COMPLEX_16 *); internal_proto(internal_unpack_c16); #endif +/* Internal auxiliary functions for the pack intrinsic. */ + +extern void pack_i1 (gfc_array_i1 *, const gfc_array_i1 *, + const gfc_array_l1 *, const gfc_array_i1 *); +internal_proto(pack_i1); + +extern void pack_i2 (gfc_array_i2 *, const gfc_array_i2 *, + const gfc_array_l1 *, const gfc_array_i2 *); +internal_proto(pack_i2); + +extern void pack_i4 (gfc_array_i4 *, const gfc_array_i4 *, + const gfc_array_l1 *, const gfc_array_i4 *); +internal_proto(pack_i4); + +extern void pack_i8 (gfc_array_i8 *, const gfc_array_i8 *, + const gfc_array_l1 *, const gfc_array_i8 *); +internal_proto(pack_i8); + +#ifdef HAVE_GFC_INTEGER_16 +extern void pack_i16 (gfc_array_i16 *, const gfc_array_i16 *, + const gfc_array_l1 *, const gfc_array_i16 *); +internal_proto(pack_i16); +#endif + +extern void pack_r4 (gfc_array_r4 *, const gfc_array_r4 *, + const gfc_array_l1 *, const gfc_array_r4 *); +internal_proto(pack_r4); + +extern void pack_r8 (gfc_array_r8 *, const gfc_array_r8 *, + const gfc_array_l1 *, const gfc_array_r8 *); +internal_proto(pack_r8); + +#ifdef HAVE_GFC_REAL_10 +extern void pack_r10 (gfc_array_r10 *, const gfc_array_r10 *, + const gfc_array_l1 *, const gfc_array_r10 *); +internal_proto(pack_r10); +#endif + +#ifdef HAVE_GFC_REAL_16 +extern void pack_r16 (gfc_array_r16 *, const gfc_array_r16 *, + const gfc_array_l1 *, const gfc_array_r16 *); +internal_proto(pack_r16); +#endif + +extern void pack_c4 (gfc_array_c4 *, const gfc_array_c4 *, + const gfc_array_l1 *, const gfc_array_c4 *); +internal_proto(pack_c4); + +extern void pack_c8 (gfc_array_c8 *, const gfc_array_c8 *, + const gfc_array_l1 *, const gfc_array_c8 *); +internal_proto(pack_c8); + +#ifdef HAVE_GFC_REAL_10 +extern void pack_c10 (gfc_array_c10 *, const gfc_array_c10 *, + const gfc_array_l1 *, const gfc_array_c10 *); +internal_proto(pack_c10); +#endif + +#ifdef HAVE_GFC_REAL_16 +extern void pack_c16 (gfc_array_c16 *, const gfc_array_c16 *, + const gfc_array_l1 *, const gfc_array_c16 *); +internal_proto(pack_c16); +#endif + /* string_intrinsics.c */ extern int compare_string (GFC_INTEGER_4, const char *, diff --git a/libgfortran/m4/pack.m4 b/libgfortran/m4/pack.m4 new file mode 100644 index 0000000..87409a5 --- /dev/null +++ b/libgfortran/m4/pack.m4 @@ -0,0 +1,312 @@ +`/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Ligbfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include +#include +#include ' + +include(iparm.m4)dnl + +`#if defined (HAVE_'rtype_name`) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, + const gfc_array_l1 *mask, const 'rtype` *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + 'rtype_name` *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const 'rtype_name` *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + 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 + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[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 this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof ('rtype_name`) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride; + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[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. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride; + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif +' \ No newline at end of file -- cgit v1.1