mirrors/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-23 10:54:07 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

re PR libfortran/32972 (performance of pack/unpack)

Browse Source 
2008-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32972
	PR libfortran/32512
	* Makefile.am:  Add new variable, i_spread_c, containing
	pack_i1.c, pack_i2.c, pack_i4.c, pack_i8.c, spread_i16.c,
	spread_r4.c, spread_r8.c, spread_r10.c, spread_r16.c,
	spread_c4.c, spread_c8.c, spread_c10.c, spread_c16.c.
	* Makefile.in:  Regenerated.
	* libgfortran.h:  Add prototypes for spread_i1, spread_i2,
	spread_i4, spread_i8, spread_i16, spread_r4, spread_r8,
	spread_c4, spread_c8, spread_c10, spread_c16,
	spread_scalar_i1, spread_scalar_i2, spread_scalar_i4,
	spread_scalar_i8, spread_scalar_i16, spread_scalar_r4
	spread_scalar_r8, spread_scalar_c4, spread_scalar_c8,
	spread_scalar_c10 and spread_scalar_c16.
	Add macros to isolate both type and size information
	from array descriptors with a single mask operation.
	* intrinsics/spread_generic.c:  Add calls to specific
	spread functions.
	* m4/spread.m4:  New file.
	* generated/spread_i1.c:  New file.
	* generated/spread_i2.c:  New file.
	* generated/spread_i4.c:  New file.
	* generated/spread_i8.c:  New file.
	* generated/spread_i16.c:  New file.
	* generated/spread_r4.c:  New file.
	* generated/spread_r8.c:  New file.
	* generated/spread_r10.c:  New file.
	* generated/spread_r16.c:  New file.
	* generated/spread_c4.c:  New file.
	* generated/spread_c8.c:  New file.
	* generated/spread_c10.c:  New file.
	* generated/spread_c16.c:  New file.

2008-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32972
	PR libfortran/32512
	* intrinsic_spread_1.f90:  New file.
	* intrinsic_spread_2.f90:  New file.
	* intrinsic_spread_3.f90:  New file.

From-SVN: r133702
This commit is contained in:
Thomas Koenig 2008-03-28 23:22:49 +00:00
parent 01d2a7d703
commit 75f2543f2e
23 changed files with 4651 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2008-03-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32972
PR libfortran/32512
* intrinsic_spread_1.f90: New file.
* intrinsic_spread_2.f90: New file.
* intrinsic_spread_3.f90: New file.
2008-03-28 Daniel Franke <franke.daniel@gmail.com>
PR fortran/34714

123
gcc/testsuite/gfortran.dg/intrinsic_spread_1.f90 Normal file
View File

@ -0,0 +1,123 @@
! { dg-do run }
program foo
implicit none
integer(kind=1), dimension (10) :: i_1
integer(kind=1), dimension (2, 3) :: a_1
integer(kind=1), dimension (2, 2, 3) :: b_1
integer(kind=2), dimension (10) :: i_2
integer(kind=2), dimension (2, 3) :: a_2
integer(kind=2), dimension (2, 2, 3) :: b_2
integer(kind=4), dimension (10) :: i_4
integer(kind=4), dimension (2, 3) :: a_4
integer(kind=4), dimension (2, 2, 3) :: b_4
integer(kind=8), dimension (10) :: i_8
integer(kind=8), dimension (2, 3) :: a_8
integer(kind=8), dimension (2, 2, 3) :: b_8
real(kind=4), dimension (10) :: r_4
real(kind=4), dimension (2, 3) :: ar_4
real(kind=4), dimension (2, 2, 3) :: br_4
real(kind=8), dimension (10) :: r_8
real(kind=8), dimension (2, 3) :: ar_8
real(kind=8), dimension (2, 2, 3) :: br_8
character (len=200) line1, line2, line3
a_1 = reshape ((/1_1, 2_1, 3_1, 4_1, 5_1, 6_1/), (/2, 3/))
b_1 = spread (a_1, 1, 2)
if (any (b_1 .ne. reshape ((/1_1, 1_1, 2_1, 2_1, 3_1, 3_1, 4_1, 4_1, 5_1, 5_1, 6_1, 6_1/), &
(/2, 2, 3/)))) &
call abort
line1 = ' '
write(line1, 9000) b_1
line2 = ' '
write(line2, 9000) spread (a_1, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9000) spread (a_1, 1, 2) + 0_1
if (line1 /= line3) call abort
i_1 = spread(1_1,1,10)
if (any(i_1 /= 1_1)) call abort
a_2 = reshape ((/1_2, 2_2, 3_2, 4_2, 5_2, 6_2/), (/2, 3/))
b_2 = spread (a_2, 1, 2)
if (any (b_2 .ne. reshape ((/1_2, 1_2, 2_2, 2_2, 3_2, 3_2, 4_2, 4_2, 5_2, 5_2, 6_2, 6_2/), &
(/2, 2, 3/)))) &
call abort
line1 = ' '
write(line1, 9000) b_2
line2 = ' '
write(line2, 9000) spread (a_2, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9000) spread (a_2, 1, 2) + 0_2
if (line1 /= line3) call abort
i_2 = spread(1_2,1,10)
if (any(i_2 /= 1_2)) call abort
a_4 = reshape ((/1_4, 2_4, 3_4, 4_4, 5_4, 6_4/), (/2, 3/))
b_4 = spread (a_4, 1, 2)
if (any (b_4 .ne. reshape ((/1_4, 1_4, 2_4, 2_4, 3_4, 3_4, 4_4, 4_4, 5_4, 5_4, 6_4, 6_4/), &
(/2, 2, 3/)))) &
call abort
line1 = ' '
write(line1, 9000) b_4
line2 = ' '
write(line2, 9000) spread (a_4, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9000) spread (a_4, 1, 2) + 0_4
if (line1 /= line3) call abort
i_4 = spread(1_4,1,10)
if (any(i_4 /= 1_4)) call abort
a_8 = reshape ((/1_8, 2_8, 3_8, 4_8, 5_8, 6_8/), (/2, 3/))
b_8 = spread (a_8, 1, 2)
if (any (b_8 .ne. reshape ((/1_8, 1_8, 2_8, 2_8, 3_8, 3_8, 4_8, 4_8, 5_8, 5_8, 6_8, 6_8/), &
(/2, 2, 3/)))) &
call abort
line1 = ' '
write(line1, 9000) b_8
line2 = ' '
write(line2, 9000) spread (a_8, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9000) spread (a_8, 1, 2) + 0_8
if (line1 /= line3) call abort
i_8 = spread(1_8,1,10)
if (any(i_8 /= 1_8)) call abort
ar_4 = reshape ((/1._4, 2._4, 3._4, 4._4, 5._4, 6._4/), (/2, 3/))
br_4 = spread (ar_4, 1, 2)
if (any (br_4 .ne. reshape ((/1._4, 1._4, 2._4, 2._4, 3._4, 3._4, &
& 4._4, 4._4, 5._4, 5._4, 6._4, 6._4/), (/2, 2, 3/)))) call abort
line1 = ' '
write(line1, 9010) br_4
line2 = ' '
write(line2, 9010) spread (ar_4, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9010) spread (ar_4, 1, 2) + 0._4
if (line1 /= line3) call abort
r_4 = spread(1._4,1,10)
if (any(r_4 /= 1._4)) call abort
ar_8 = reshape ((/1._8, 2._8, 3._8, 4._8, 5._8, 6._8/), (/2, 3/))
br_8 = spread (ar_8, 1, 2)
if (any (br_8 .ne. reshape ((/1._8, 1._8, 2._8, 2._8, 3._8, 3._8, &
& 4._8, 4._8, 5._8, 5._8, 6._8, 6._8/), (/2, 2, 3/)))) call abort
line1 = ' '
write(line1, 9010) br_8
line2 = ' '
write(line2, 9010) spread (ar_8, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9010) spread (ar_8, 1, 2) + 0._8
if (line1 /= line3) call abort
r_8 = spread(1._8,1,10)
if (any(r_8 /= 1._8)) call abort
9000 format(12I3)
9010 format(12F7.3)
end program

29
gcc/testsuite/gfortran.dg/intrinsic_spread_2.f90 Normal file
View File

@ -0,0 +1,29 @@
! { dg-do run }
! { dg-require-effective-target fortran_large_real }
program foo
implicit none
integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
real(kind=k), dimension(10) :: r_k
real(kind=k), dimension (2, 3) :: ar_k
real(kind=k), dimension (2, 2, 3) :: br_k
character (len=200) line1, line2, line3
ar_k = reshape ((/1._k, 2._k, 3._k, 4._k, 5._k, 6._k/), (/2, 3/))
br_k = spread (ar_k, 1, 2)
if (any (br_k .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, &
& 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) call abort
line1 = ' '
write(line1, 9010) br_k
line2 = ' '
write(line2, 9010) spread (ar_k, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9010) spread (ar_k, 1, 2) + 0._k
if (line1 /= line3) call abort
r_k = spread(1._k,1,10)
if (any(r_k /= 1._k)) call abort
9010 format(12F7.3)
end program

31
gcc/testsuite/gfortran.dg/intrinsic_spread_3.f90 Normal file
View File

@ -0,0 +1,31 @@
! { dg-do run }
! { dg-require-effective-target fortran_large_int }
program foo
implicit none
integer,parameter :: k = selected_int_kind (range (0_8) + 1)
integer(kind=k), dimension(10) :: i_k
integer(kind=k), dimension (2, 3) :: a_k
integer(kind=k), dimension (2, 2, 3) :: b_k
character (len=200) line1, line2, line3
a_k = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k/), (/2, 3/))
b_k = spread (a_k, 1, 2)
if (any (b_k .ne. reshape ((/1_k, 1_k, 2_k, 2_k, 3_k, 3_k, 4_k, 4_k, 5_k, 5_k, 6_k, 6_k/), &
(/2, 2, 3/)))) &
call abort
line1 = ' '
write(line1, 9000) b_k
line2 = ' '
write(line2, 9000) spread (a_k, 1, 2)
if (line1 /= line2) call abort
line3 = ' '
write(line3, 9000) spread (a_k, 1, 2) + 0_k
if (line1 /= line3) call abort
i_k = spread(1_k,1,10)
if (any(i_k /= 1_k)) call abort
9000 format(12I3)
end program

35
libgfortran/ChangeLog
View File

@ -1,3 +1,38 @@
2008-03-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32972
PR libfortran/32512
* Makefile.am: Add new variable, i_spread_c, containing
pack_i1.c, pack_i2.c, pack_i4.c, pack_i8.c, spread_i16.c,
spread_r4.c, spread_r8.c, spread_r10.c, spread_r16.c,
spread_c4.c, spread_c8.c, spread_c10.c, spread_c16.c.
* Makefile.in: Regenerated.
* libgfortran.h: Add prototypes for spread_i1, spread_i2,
spread_i4, spread_i8, spread_i16, spread_r4, spread_r8,
spread_c4, spread_c8, spread_c10, spread_c16,
spread_scalar_i1, spread_scalar_i2, spread_scalar_i4,
spread_scalar_i8, spread_scalar_i16, spread_scalar_r4
spread_scalar_r8, spread_scalar_c4, spread_scalar_c8,
spread_scalar_c10 and spread_scalar_c16.
Add macros to isolate both type and size information
from array descriptors with a single mask operation.
* intrinsics/spread_generic.c: Add calls to specific
spread functions.
* m4/spread.m4: New file.
* generated/spread_i1.c: New file.
* generated/spread_i2.c: New file.
* generated/spread_i4.c: New file.
* generated/spread_i8.c: New file.
* generated/spread_i16.c: New file.
* generated/spread_r4.c: New file.
* generated/spread_r8.c: New file.
* generated/spread_r10.c: New file.
* generated/spread_r16.c: New file.
* generated/spread_c4.c: New file.
* generated/spread_c8.c: New file.
* generated/spread_c10.c: New file.
* generated/spread_c16.c: New file.
2008-03-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/35699

22
libgfortran/Makefile.am
View File

@ -506,6 +506,21 @@ $(srcdir)/generated/unpack_c8.c \
$(srcdir)/generated/unpack_c10.c \
$(srcdir)/generated/unpack_c16.c
i_spread_c = \
$(srcdir)/generated/spread_i1.c \
$(srcdir)/generated/spread_i2.c \
$(srcdir)/generated/spread_i4.c \
$(srcdir)/generated/spread_i8.c \
$(srcdir)/generated/spread_i16.c \
$(srcdir)/generated/spread_r4.c \
$(srcdir)/generated/spread_r8.c \
$(srcdir)/generated/spread_r10.c \
$(srcdir)/generated/spread_r16.c \
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
$(srcdir)/generated/spread_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 \
@ -515,7 +530,7 @@ m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.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/pack.m4 \
m4/unpack.m4
m4/unpack.m4 m4/spread.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) \
@ -524,7 +539,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_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_pack_c) $(i_unpack_c) \
selected_int_kind.inc selected_real_kind.inc kinds.h \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
kinds.inc c99_protos.inc fpu-target.h
# Machine generated specifics
@ -845,6 +860,9 @@ $(i_pack_c): m4/pack.m4 $(I_M4_DEPS)
$(i_unpack_c): m4/unpack.m4 $(I_M4_DEPS)
$(M4) -Dfile=$@ -I$(srcdir)/m4 unpack.m4 > $@
$(i_spread_c): m4/spread.m4 $(I_M4_DEPS)
$(M4) -Dfile=$@ -I$(srcdir)/m4 spread.m4 > $@
$(gfor_built_specific_src): m4/specific.m4 m4/head.m4
$(M4) -Dfile=$@ -I$(srcdir)/m4 specific.m4 > $@

170
libgfortran/Makefile.in
View File

@ -382,7 +382,20 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \
$(srcdir)/generated/unpack_c4.c \
$(srcdir)/generated/unpack_c8.c \
$(srcdir)/generated/unpack_c10.c \
$(srcdir)/generated/unpack_c16.c selected_int_kind.inc \
$(srcdir)/generated/unpack_c16.c \
$(srcdir)/generated/spread_i1.c \
$(srcdir)/generated/spread_i2.c \
$(srcdir)/generated/spread_i4.c \
$(srcdir)/generated/spread_i8.c \
$(srcdir)/generated/spread_i16.c \
$(srcdir)/generated/spread_r4.c \
$(srcdir)/generated/spread_r8.c \
$(srcdir)/generated/spread_r10.c \
$(srcdir)/generated/spread_r16.c \
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
$(srcdir)/generated/spread_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 \
@ -659,7 +672,11 @@ am__objects_31 = unpack_i1.lo unpack_i2.lo unpack_i4.lo unpack_i8.lo \
unpack_i16.lo unpack_r4.lo unpack_r8.lo unpack_r10.lo \
unpack_r16.lo unpack_c4.lo unpack_c8.lo unpack_c10.lo \
unpack_c16.lo
am__objects_32 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \
am__objects_32 = spread_i1.lo spread_i2.lo spread_i4.lo spread_i8.lo \
spread_i16.lo spread_r4.lo spread_r8.lo spread_r10.lo \
spread_r16.lo spread_c4.lo spread_c8.lo spread_c10.lo \
spread_c16.lo
am__objects_33 = $(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) \
@ -668,11 +685,12 @@ am__objects_32 = $(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_30) $(am__objects_31)
am__objects_33 = close.lo file_pos.lo format.lo inquire.lo \
$(am__objects_29) $(am__objects_30) $(am__objects_31) \
$(am__objects_32)
am__objects_34 = 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_34 = associated.lo abort.lo access.lo args.lo \
am__objects_35 = 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 \
@ -686,8 +704,8 @@ am__objects_34 = 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_35 =
am__objects_36 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
am__objects_36 =
am__objects_37 = _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 \
@ -711,18 +729,18 @@ am__objects_36 = _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_37 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
am__objects_38 = _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_38 = misc_specifics.lo
am__objects_39 = $(am__objects_36) $(am__objects_37) $(am__objects_38) \
am__objects_39 = misc_specifics.lo
am__objects_40 = $(am__objects_37) $(am__objects_38) $(am__objects_39) \
dprod_r8.lo f2c_specifics.lo
am__objects_40 = $(am__objects_1) $(am__objects_32) $(am__objects_33) \
$(am__objects_34) $(am__objects_35) $(am__objects_39)
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_40)
am__objects_41 = $(am__objects_1) $(am__objects_33) $(am__objects_34) \
$(am__objects_35) $(am__objects_36) $(am__objects_40)
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_41)
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
libgfortranbegin_la_LIBADD =
@ -1386,6 +1404,21 @@ $(srcdir)/generated/unpack_c8.c \
$(srcdir)/generated/unpack_c10.c \
$(srcdir)/generated/unpack_c16.c
i_spread_c = \
$(srcdir)/generated/spread_i1.c \
$(srcdir)/generated/spread_i2.c \
$(srcdir)/generated/spread_i4.c \
$(srcdir)/generated/spread_i8.c \
$(srcdir)/generated/spread_i16.c \
$(srcdir)/generated/spread_r4.c \
$(srcdir)/generated/spread_r8.c \
$(srcdir)/generated/spread_r10.c \
$(srcdir)/generated/spread_r16.c \
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
$(srcdir)/generated/spread_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 \
@ -1395,7 +1428,7 @@ m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.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/pack.m4 \
m4/unpack.m4
m4/unpack.m4 m4/spread.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) \
@ -1404,7 +1437,7 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_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_pack_c) $(i_unpack_c) \
selected_int_kind.inc selected_real_kind.inc kinds.h \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
kinds.inc c99_protos.inc fpu-target.h
@ -2054,7 +2087,20 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spacing_r16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spacing_r4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spacing_r8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_generic.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_i1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_i16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_i2.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_i4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_i8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_r10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_r16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_r4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_r8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/stat.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/stop.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/string.Plo@am__quote@
@ -4884,6 +4930,97 @@ unpack_c16.lo: $(srcdir)/generated/unpack_c16.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 unpack_c16.lo `test -f '$(srcdir)/generated/unpack_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/unpack_c16.c
spread_i1.lo: $(srcdir)/generated/spread_i1.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_i1.lo -MD -MP -MF "$(DEPDIR)/spread_i1.Tpo" -c -o spread_i1.lo `test -f '$(srcdir)/generated/spread_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i1.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_i1.Tpo" "$(DEPDIR)/spread_i1.Plo"; else rm -f "$(DEPDIR)/spread_i1.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_i1.c' object='spread_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 spread_i1.lo `test -f '$(srcdir)/generated/spread_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i1.c
spread_i2.lo: $(srcdir)/generated/spread_i2.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_i2.lo -MD -MP -MF "$(DEPDIR)/spread_i2.Tpo" -c -o spread_i2.lo `test -f '$(srcdir)/generated/spread_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i2.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_i2.Tpo" "$(DEPDIR)/spread_i2.Plo"; else rm -f "$(DEPDIR)/spread_i2.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_i2.c' object='spread_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 spread_i2.lo `test -f '$(srcdir)/generated/spread_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i2.c
spread_i4.lo: $(srcdir)/generated/spread_i4.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_i4.lo -MD -MP -MF "$(DEPDIR)/spread_i4.Tpo" -c -o spread_i4.lo `test -f '$(srcdir)/generated/spread_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i4.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_i4.Tpo" "$(DEPDIR)/spread_i4.Plo"; else rm -f "$(DEPDIR)/spread_i4.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_i4.c' object='spread_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 spread_i4.lo `test -f '$(srcdir)/generated/spread_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i4.c
spread_i8.lo: $(srcdir)/generated/spread_i8.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_i8.lo -MD -MP -MF "$(DEPDIR)/spread_i8.Tpo" -c -o spread_i8.lo `test -f '$(srcdir)/generated/spread_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i8.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_i8.Tpo" "$(DEPDIR)/spread_i8.Plo"; else rm -f "$(DEPDIR)/spread_i8.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_i8.c' object='spread_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 spread_i8.lo `test -f '$(srcdir)/generated/spread_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i8.c
spread_i16.lo: $(srcdir)/generated/spread_i16.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_i16.lo -MD -MP -MF "$(DEPDIR)/spread_i16.Tpo" -c -o spread_i16.lo `test -f '$(srcdir)/generated/spread_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i16.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_i16.Tpo" "$(DEPDIR)/spread_i16.Plo"; else rm -f "$(DEPDIR)/spread_i16.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_i16.c' object='spread_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 spread_i16.lo `test -f '$(srcdir)/generated/spread_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_i16.c
spread_r4.lo: $(srcdir)/generated/spread_r4.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_r4.lo -MD -MP -MF "$(DEPDIR)/spread_r4.Tpo" -c -o spread_r4.lo `test -f '$(srcdir)/generated/spread_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r4.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_r4.Tpo" "$(DEPDIR)/spread_r4.Plo"; else rm -f "$(DEPDIR)/spread_r4.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_r4.c' object='spread_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 spread_r4.lo `test -f '$(srcdir)/generated/spread_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r4.c
spread_r8.lo: $(srcdir)/generated/spread_r8.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_r8.lo -MD -MP -MF "$(DEPDIR)/spread_r8.Tpo" -c -o spread_r8.lo `test -f '$(srcdir)/generated/spread_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r8.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_r8.Tpo" "$(DEPDIR)/spread_r8.Plo"; else rm -f "$(DEPDIR)/spread_r8.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_r8.c' object='spread_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 spread_r8.lo `test -f '$(srcdir)/generated/spread_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r8.c
spread_r10.lo: $(srcdir)/generated/spread_r10.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_r10.lo -MD -MP -MF "$(DEPDIR)/spread_r10.Tpo" -c -o spread_r10.lo `test -f '$(srcdir)/generated/spread_r10.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r10.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_r10.Tpo" "$(DEPDIR)/spread_r10.Plo"; else rm -f "$(DEPDIR)/spread_r10.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_r10.c' object='spread_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 spread_r10.lo `test -f '$(srcdir)/generated/spread_r10.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r10.c
spread_r16.lo: $(srcdir)/generated/spread_r16.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_r16.lo -MD -MP -MF "$(DEPDIR)/spread_r16.Tpo" -c -o spread_r16.lo `test -f '$(srcdir)/generated/spread_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r16.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_r16.Tpo" "$(DEPDIR)/spread_r16.Plo"; else rm -f "$(DEPDIR)/spread_r16.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_r16.c' object='spread_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 spread_r16.lo `test -f '$(srcdir)/generated/spread_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_r16.c
spread_c4.lo: $(srcdir)/generated/spread_c4.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_c4.lo -MD -MP -MF "$(DEPDIR)/spread_c4.Tpo" -c -o spread_c4.lo `test -f '$(srcdir)/generated/spread_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c4.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_c4.Tpo" "$(DEPDIR)/spread_c4.Plo"; else rm -f "$(DEPDIR)/spread_c4.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_c4.c' object='spread_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 spread_c4.lo `test -f '$(srcdir)/generated/spread_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c4.c
spread_c8.lo: $(srcdir)/generated/spread_c8.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_c8.lo -MD -MP -MF "$(DEPDIR)/spread_c8.Tpo" -c -o spread_c8.lo `test -f '$(srcdir)/generated/spread_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c8.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_c8.Tpo" "$(DEPDIR)/spread_c8.Plo"; else rm -f "$(DEPDIR)/spread_c8.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_c8.c' object='spread_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 spread_c8.lo `test -f '$(srcdir)/generated/spread_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c8.c
spread_c10.lo: $(srcdir)/generated/spread_c10.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_c10.lo -MD -MP -MF "$(DEPDIR)/spread_c10.Tpo" -c -o spread_c10.lo `test -f '$(srcdir)/generated/spread_c10.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c10.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_c10.Tpo" "$(DEPDIR)/spread_c10.Plo"; else rm -f "$(DEPDIR)/spread_c10.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_c10.c' object='spread_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 spread_c10.lo `test -f '$(srcdir)/generated/spread_c10.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c10.c
spread_c16.lo: $(srcdir)/generated/spread_c16.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_c16.lo -MD -MP -MF "$(DEPDIR)/spread_c16.Tpo" -c -o spread_c16.lo `test -f '$(srcdir)/generated/spread_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_c16.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/spread_c16.Tpo" "$(DEPDIR)/spread_c16.Plo"; else rm -f "$(DEPDIR)/spread_c16.Tpo"; exit 1; fi
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/spread_c16.c' object='spread_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 spread_c16.lo `test -f '$(srcdir)/generated/spread_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/spread_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
@ -5841,6 +5978,9 @@ fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER)
@MAINTAINER_MODE_TRUE@$(i_unpack_c): m4/unpack.m4 $(I_M4_DEPS)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 unpack.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_spread_c): m4/spread.m4 $(I_M4_DEPS)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 spread.m4 > $@
@MAINTAINER_MODE_TRUE@$(gfor_built_specific_src): m4/specific.m4 m4/head.m4
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 specific.m4 > $@

277
libgfortran/generated/spread_c10.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_COMPLEX_10)
void
spread_c10 (gfc_array_c10 *ret, const gfc_array_c10 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_COMPLEX_10 *rptr;
GFC_COMPLEX_10 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_COMPLEX_10 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_10));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_c10 (gfc_array_c10 *ret, const GFC_COMPLEX_10 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_COMPLEX_10 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_10));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_c16.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_COMPLEX_16)
void
spread_c16 (gfc_array_c16 *ret, const gfc_array_c16 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_COMPLEX_16 *rptr;
GFC_COMPLEX_16 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_COMPLEX_16 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_16));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_c16 (gfc_array_c16 *ret, const GFC_COMPLEX_16 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_COMPLEX_16 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_16));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_c4.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_COMPLEX_4)
void
spread_c4 (gfc_array_c4 *ret, const gfc_array_c4 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_COMPLEX_4 *rptr;
GFC_COMPLEX_4 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_COMPLEX_4 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_4));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_c4 (gfc_array_c4 *ret, const GFC_COMPLEX_4 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_COMPLEX_4 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_4));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_c8.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_COMPLEX_8)
void
spread_c8 (gfc_array_c8 *ret, const gfc_array_c8 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_COMPLEX_8 *rptr;
GFC_COMPLEX_8 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_COMPLEX_8 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_8));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_c8 (gfc_array_c8 *ret, const GFC_COMPLEX_8 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_COMPLEX_8 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_8));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_i1.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_INTEGER_1)
void
spread_i1 (gfc_array_i1 *ret, const gfc_array_i1 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_INTEGER_1 *rptr;
GFC_INTEGER_1 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_INTEGER_1 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_1));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_i1 (gfc_array_i1 *ret, const GFC_INTEGER_1 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_INTEGER_1 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_1));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_i16.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_INTEGER_16)
void
spread_i16 (gfc_array_i16 *ret, const gfc_array_i16 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_INTEGER_16 *rptr;
GFC_INTEGER_16 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_INTEGER_16 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_16));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_i16 (gfc_array_i16 *ret, const GFC_INTEGER_16 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_INTEGER_16 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_16));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_i2.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_INTEGER_2)
void
spread_i2 (gfc_array_i2 *ret, const gfc_array_i2 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_INTEGER_2 *rptr;
GFC_INTEGER_2 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_INTEGER_2 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_2));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_i2 (gfc_array_i2 *ret, const GFC_INTEGER_2 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_INTEGER_2 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_2));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_i4.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_INTEGER_4)
void
spread_i4 (gfc_array_i4 *ret, const gfc_array_i4 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_INTEGER_4 *rptr;
GFC_INTEGER_4 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_INTEGER_4 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_4));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_i4 (gfc_array_i4 *ret, const GFC_INTEGER_4 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_INTEGER_4 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_4));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_i8.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_INTEGER_8)
void
spread_i8 (gfc_array_i8 *ret, const gfc_array_i8 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_INTEGER_8 *rptr;
GFC_INTEGER_8 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_INTEGER_8 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_8));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_i8 (gfc_array_i8 *ret, const GFC_INTEGER_8 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_INTEGER_8 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_8));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_r10.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_REAL_10)
void
spread_r10 (gfc_array_r10 *ret, const gfc_array_r10 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_REAL_10 *rptr;
GFC_REAL_10 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_REAL_10 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_10));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_r10 (gfc_array_r10 *ret, const GFC_REAL_10 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_REAL_10 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_10));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_r16.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_REAL_16)
void
spread_r16 (gfc_array_r16 *ret, const gfc_array_r16 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_REAL_16 *rptr;
GFC_REAL_16 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_REAL_16 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_16));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_r16 (gfc_array_r16 *ret, const GFC_REAL_16 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_REAL_16 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_16));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_r4.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_REAL_4)
void
spread_r4 (gfc_array_r4 *ret, const gfc_array_r4 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_REAL_4 *rptr;
GFC_REAL_4 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_REAL_4 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_4));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_r4 (gfc_array_r4 *ret, const GFC_REAL_4 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_REAL_4 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_4));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

277
libgfortran/generated/spread_r8.c Normal file
View File

@ -0,0 +1,277 @@
/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>
#if defined (HAVE_GFC_REAL_8)
void
spread_r8 (gfc_array_r8 *ret, const gfc_array_r8 *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
GFC_REAL_8 *rptr;
GFC_REAL_8 *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const GFC_REAL_8 *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_8));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_r8 (gfc_array_r8 *ret, const GFC_REAL_8 *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
GFC_REAL_8 * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_8));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif

174
libgfortran/intrinsics/spread_generic.c
View File

@ -276,6 +276,92 @@ void
spread (gfc_array_char *ret, const gfc_array_char *source,
const index_type *along, const index_type *pncopies)
{
index_type type_size;
type_size = GFC_DTYPE_TYPE_SIZE(ret);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_REAL_4:
spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_REAL_8:
spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
*along, *pncopies);
return;
#ifdef GFC_HAVE_REAL_10
case GFC_DTYPE_REAL_10:
spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
*along, *pncopies);
return;
#endif
#ifdef GFC_HAVE_REAL_16
case GFC_DTYPE_REAL_16:
spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_COMPLEX_4:
spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_COMPLEX_8:
spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
*along, *pncopies);
return;
#ifdef GFC_HAVE_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
*along, *pncopies);
return;
#endif
#ifdef GFC_HAVE_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
*along, *pncopies);
return;
#endif
}
spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
}
@ -304,8 +390,96 @@ void
spread_scalar (gfc_array_char *ret, const char *source,
const index_type *along, const index_type *pncopies)
{
index_type type_size;
if (!ret->dtype)
runtime_error ("return array missing descriptor in spread()");
type_size = GFC_DTYPE_TYPE_SIZE(ret);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_REAL_4:
spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_REAL_8:
spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
*along, *pncopies);
return;
#endif
#ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
*along, *pncopies);
return;
#endif
case GFC_DTYPE_COMPLEX_4:
spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
*along, *pncopies);
return;
case GFC_DTYPE_COMPLEX_8:
spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
*along, *pncopies);
return;
#endif
#ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
*along, *pncopies);
return;
#endif
}
spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
}

196
libgfortran/libgfortran.h
View File

@ -308,6 +308,66 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
#define GFC_DESCRIPTOR_DATA(desc) ((desc)->data)
#define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->dtype)
/* Macros to get both the size and the type with a single masking operation */
#define GFC_DTYPE_SIZE_MASK \
((~((index_type) 0) >> GFC_DTYPE_SIZE_SHIFT) << GFC_DTYPE_SIZE_SHIFT)
#define GFC_DTYPE_TYPE_SIZE_MASK (GFC_DTYPE_SIZE_MASK | GFC_DTYPE_TYPE_MASK)
#define GFC_DTYPE_TYPE_SIZE(desc) ((desc)->dtype & GFC_DTYPE_TYPE_SIZE_MASK)
#define GFC_DTYPE_INTEGER_1 ((GFC_DTYPE_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_INTEGER_2 ((GFC_DTYPE_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_INTEGER_4 ((GFC_DTYPE_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_INTEGER_8 ((GFC_DTYPE_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT))
#ifdef HAVE_GFC_INTEGER_16
#define GFC_DTYPE_INTEGER_16 ((GFC_DTYPE_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT))
#endif
#define GFC_DTYPE_LOGICAL_1 ((GFC_DTYPE_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_LOGICAL_1) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_LOGICAL_2 ((GFC_DTYPE_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_LOGICAL_2) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_LOGICAL_4 ((GFC_DTYPE_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_LOGICAL_4) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_LOGICAL_8 ((GFC_DTYPE_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_LOGICAL_8) << GFC_DTYPE_SIZE_SHIFT))
#ifdef HAVE_GFC_LOGICAL_16
#define GFC_DTYPE_LOGICAL_16 ((GFC_DTYPE_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_LOGICAL_16) << GFC_DTYPE_SIZE_SHIFT))
#endif
#define GFC_DTYPE_REAL_4 ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_REAL_4) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_REAL_8 ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_REAL_8) << GFC_DTYPE_SIZE_SHIFT))
#ifdef HAVE_GFC_REAL_10
#define GFC_DTYPE_REAL_10 ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_REAL_10) << GFC_DTYPE_SIZE_SHIFT))
#endif
#ifdef HAVE_GFC_REAL_16
#define GFC_DTYPE_REAL_16 ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_REAL_16) << GFC_DTYPE_SIZE_SHIFT))
#endif
#define GFC_DTYPE_COMPLEX_4 ((GFC_DTYPE_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_COMPLEX_4) << GFC_DTYPE_SIZE_SHIFT))
#define GFC_DTYPE_COMPLEX_8 ((GFC_DTYPE_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_COMPLEX_8) << GFC_DTYPE_SIZE_SHIFT))
#ifdef HAVE_GFC_COMPLEX_10
#define GFC_DTYPE_COMPLEX_10 ((GFC_DTYPE_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_COMPLEX_10) << GFC_DTYPE_SIZE_SHIFT))
#endif
#ifdef HAVE_GFC_COMPLEX_16
#define GFC_DTYPE_COMPLEX_16 ((GFC_DTYPE_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
| (sizeof(GFC_COMPLEX_16) << GFC_DTYPE_SIZE_SHIFT))
#endif
/* Runtime library include. */
#define stringize(x) expand_macro(x)
#define expand_macro(x) # x
@ -910,6 +970,142 @@ extern void unpack1_c16 (gfc_array_c16 *, const gfc_array_c16 *,
internal_proto(unpack1_c16);
#endif
/* Helper functions for spread. */
extern void spread_i1 (gfc_array_i1 *, const gfc_array_i1 *,
const index_type, const index_type);
internal_proto(spread_i1);
extern void spread_i2 (gfc_array_i2 *, const gfc_array_i2 *,
const index_type, const index_type);
internal_proto(spread_i2);
extern void spread_i4 (gfc_array_i4 *, const gfc_array_i4 *,
const index_type, const index_type);
internal_proto(spread_i4);
extern void spread_i8 (gfc_array_i8 *, const gfc_array_i8 *,
const index_type, const index_type);
internal_proto(spread_i8);
#ifdef HAVE_GFC_INTEGER_16
extern void spread_i16 (gfc_array_i16 *, const gfc_array_i16 *,
const index_type, const index_type);
internal_proto(spread_i16);
#endif
extern void spread_r4 (gfc_array_r4 *, const gfc_array_r4 *,
const index_type, const index_type);
internal_proto(spread_r4);
extern void spread_r8 (gfc_array_r8 *, const gfc_array_r8 *,
const index_type, const index_type);
internal_proto(spread_r8);
#ifdef HAVE_GFC_REAL_10
extern void spread_r10 (gfc_array_r10 *, const gfc_array_r10 *,
const index_type, const index_type);
internal_proto(spread_r10);
#endif
#ifdef HAVE_GFC_REAL_16
extern void spread_r16 (gfc_array_r16 *, const gfc_array_r16 *,
const index_type, const index_type);
internal_proto(spread_r16);
#endif
extern void spread_c4 (gfc_array_c4 *, const gfc_array_c4 *,
const index_type, const index_type);
internal_proto(spread_c4);
extern void spread_c8 (gfc_array_c8 *, const gfc_array_c8 *,
const index_type, const index_type);
internal_proto(spread_c8);
#ifdef HAVE_GFC_COMPLEX_10
extern void spread_c10 (gfc_array_c10 *, const gfc_array_c10 *,
const index_type, const index_type);
internal_proto(spread_c10);
#endif
#ifdef HAVE_GFC_COMPLEX_16
extern void spread_c16 (gfc_array_c16 *, const gfc_array_c16 *,
const index_type, const index_type);
internal_proto(spread_c16);
#endif
extern void spread_scalar_i1 (gfc_array_i1 *, const GFC_INTEGER_1 *,
const index_type, const index_type);
internal_proto(spread_scalar_i1);
extern void spread_scalar_i2 (gfc_array_i2 *, const GFC_INTEGER_2 *,
const index_type, const index_type);
internal_proto(spread_scalar_i2);
extern void spread_scalar_i4 (gfc_array_i4 *, const GFC_INTEGER_4 *,
const index_type, const index_type);
internal_proto(spread_scalar_i4);
extern void spread_scalar_i8 (gfc_array_i8 *, const GFC_INTEGER_8 *,
const index_type, const index_type);
internal_proto(spread_scalar_i8);
#ifdef HAVE_GFC_INTEGER_16
extern void spread_scalar_i16 (gfc_array_i16 *, const GFC_INTEGER_16 *,
const index_type, const index_type);
internal_proto(spread_scalar_i16);
#endif
extern void spread_scalar_r4 (gfc_array_r4 *, const GFC_REAL_4 *,
const index_type, const index_type);
internal_proto(spread_scalar_r4);
extern void spread_scalar_r8 (gfc_array_r8 *, const GFC_REAL_8 *,
const index_type, const index_type);
internal_proto(spread_scalar_r8);
#ifdef HAVE_GFC_REAL_10
extern void spread_scalar_r10 (gfc_array_r10 *, const GFC_REAL_10 *,
const index_type, const index_type);
internal_proto(spread_scalar_r10);
#endif
#ifdef HAVE_GFC_REAL_16
extern void spread_scalar_r16 (gfc_array_r16 *, const GFC_REAL_16 *,
const index_type, const index_type);
internal_proto(spread_scalar_r16);
#endif
extern void spread_scalar_c4 (gfc_array_c4 *, const GFC_COMPLEX_4 *,
const index_type, const index_type);
internal_proto(spread_scalar_c4);
extern void spread_scalar_c8 (gfc_array_c8 *, const GFC_COMPLEX_8 *,
const index_type, const index_type);
internal_proto(spread_scalar_c8);
#ifdef HAVE_GFC_COMPLEX_10
extern void spread_scalar_c10 (gfc_array_c10 *, const GFC_COMPLEX_10 *,
const index_type, const index_type);
internal_proto(spread_scalar_c10);
#endif
#ifdef HAVE_GFC_COMPLEX_16
extern void spread_scalar_c16 (gfc_array_c16 *, const GFC_COMPLEX_16 *,
const index_type, const index_type);
internal_proto(spread_scalar_c16);
#endif
/* string_intrinsics.c */
extern int compare_string (GFC_INTEGER_4, const char *,

279
libgfortran/m4/spread.m4 Normal file
View File

@ -0,0 +1,279 @@
`/* Special implementation of the SPREAD intrinsic
Copyright 2008 Free Software Foundation, Inc.
Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
spread_generic.c written by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 <stdlib.h>
#include <assert.h>
#include <string.h>'
include(iparm.m4)dnl
`#if defined (HAVE_'rtype_name`)
void
spread_'rtype_code` ('rtype` *ret, const 'rtype` *source,
const index_type along, const index_type pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
'rtype_name` *rptr;
'rtype_name` *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const 'rtype_name` *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = pncopies;
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
if (n == along - 1)
{
ret->dim[n].ubound = ncopies - 1;
rdelta = rs;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = rs;
ret->dim[n].ubound = extent[dim]-1;
rs *= extent[dim];
dim++;
}
}
ret->offset = 0;
if (rs > 0)
ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
else
{
ret->data = internal_malloc_size (1);
return;
}
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == along - 1)
{
rdelta = ret->dim[n].stride;
}
else
{
count[dim] = 0;
extent[dim] = source->dim[dim].ubound + 1
- source->dim[dim].lbound;
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = source->dim[dim].stride;
rstride[dim] = ret->dim[n].stride;
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = 1;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->data;
sptr = source->data;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
*dest = *sptr;
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
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];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
/* This version of spread_internal treats the special case of a scalar
source. This is much simpler than the more general case above. */
void
spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source,
const index_type along, const index_type pncopies)
{
int n;
int ncopies = pncopies;
'rtype_name` * dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->data == NULL)
{
ret->data = internal_malloc_size (ncopies * sizeof ('rtype_name`));
ret->offset = 0;
ret->dim[0].stride = 1;
ret->dim[0].lbound = 0;
ret->dim[0].ubound = ncopies - 1;
}
else
{
if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
/ ret->dim[0].stride)
runtime_error ("dim too large in spread()");
}
dest = ret->data;
stride = ret->dim[0].stride;
for (n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
#endif
'