From: Thomas Koenig Date: Sun, 13 Apr 2008 20:15:58 +0000 (+0000) Subject: re PR libfortran/32972 (performance of pack/unpack) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c7d0f4d5fabc279dd81330ebffdf037b31420706;p=gcc.git re PR libfortran/32972 (performance of pack/unpack) 2008-04-13 Thomas Koenig Francois-Xavier Coudert PR libfortran/32972 PR libfortran/32512 configure.ac: Add test for uintptr_t. configure: Regenerated. config.h.in: Regenerated. * libgfortran.h: GFC_DTYPE_DERIVED_1: New macro. GFC_DTYPE_DERIVED_2: New macro. GFC_DTYPE_DERIVED_4: New macro. GFC_DTYPE_DERIVED_8: New macro. GFC_DTYPE_DERIVED_16: New macro. GFC_UNALIGNED_2: New macro. GFC_UNALIGNED_4: New macro. GFC_UNALIGNED_8: New macro. GFC_UNALIGNED_16: New macro. intptr_t: Define if we don't have it. uintptr_t: Likewise. * runtime/backtrace.c (show_backtrace): Use intptr_t. * intrinsics/signal.c (signal_sub): Likewise. (signal_sub_int): Likewise. (alarm_sub_int_i4): Likewise. * intrinsics/spread_generic.c (spread): Use the integer routines for handling derived types of sizes 1, 2, 4, 8 and 16 if the alignment of all pointers is correct. (spread_scalar): Likewise. * intrinsics/pack_generic.c (pack): Likewise. Use GFD_DTYPE_TYPE_SIZE to avoid nested switch statements. * intrinsics/unpack_generic.c (unpack1): Likewise. (unpack0): Likewise. * runtime/in_pack_generic.c (internal_pack): Likewise. * runtime/in_unpack_generic.c (internal_unpack): Likewise. 2008-04-13 Thomas Koenig PR libfortran/32972 PR libfortran/32512 * gfortran.dg/internal_pack_1.f90: Add test for derived type. * gfortran.dg/intrinsic_spread_1.f90: Likewise. * gfortran.dg/intrinsic_pack_1.f90: Likewise. * gfortran.dg/intrinsic_unpack_1.f90: Likewise. Co-Authored-By: Francois-Xavier Coudert From-SVN: r134245 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6932bedb8f4..aaa76f56ff8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2008-04-13 Thomas Koenig + + PR libfortran/32972 + PR libfortran/32512 + * gfortran.dg/internal_pack_1.f90: Add test for derived type. + * gfortran.dg/intrinsic_spread_1.f90: Likewise. + * gfortran.dg/intrinsic_pack_1.f90: Likewise. + * gfortran.dg/intrinsic_unpack_1.f90: Likewise. + 2008-04-13 Samuel Tardieu PR ada/17985 diff --git a/gcc/testsuite/gfortran.dg/internal_pack_1.f90 b/gcc/testsuite/gfortran.dg/internal_pack_1.f90 index 6c3781ba9b2..aded78dc26a 100644 --- a/gcc/testsuite/gfortran.dg/internal_pack_1.f90 +++ b/gcc/testsuite/gfortran.dg/internal_pack_1.f90 @@ -11,6 +11,11 @@ program main real(kind=8), dimension(3) :: r8 complex(kind=4), dimension(3) :: c4 complex(kind=8), dimension(3) :: c8 + type i8_t + sequence + integer(kind=8) :: v + end type i8_t + type(i8_t), dimension(3) :: d_i8 i1 = (/ -1, 1, -3 /) call sub_i1(i1(1:3:2)) @@ -46,6 +51,10 @@ program main if (any(real(c8) /= (/ 3.0_4, 1.0_4, 2.0_4/))) call abort if (any(aimag(c8) /= 0._4)) call abort + d_i8%v = (/ -1, 1, -3 /) + call sub_d_i8(d_i8(1:3:2)) + if (any(d_i8%v /= (/ 3, 1, 2 /))) call abort + end program main subroutine sub_i1(i) @@ -113,3 +122,15 @@ subroutine sub_c4(r) r(1) = 3._4 r(2) = 2._4 end subroutine sub_c4 + +subroutine sub_d_i8(i) + type i8_t + sequence + integer(kind=8) :: v + end type i8_t + type(i8_t), dimension(2) :: i + if (i(1)%v /= -1) call abort + if (i(2)%v /= -3) call abort + i(1)%v = 3 + i(2)%v = 2 +end subroutine sub_d_i8 diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 index e464503c963..22d110ba77c 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_1.f90 @@ -29,6 +29,34 @@ program main integer(kind=8), dimension(9) :: vi8 integer(kind=8), dimension(9) :: ri8 + type i1_t + integer(kind=1) :: v + end type i1_t + type(i1_t), dimension(3,3) :: d_i1 + type(i1_t), dimension(9) :: d_vi1 + type(i1_t), dimension(9) :: d_ri1 + + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension(3,3) :: d_i4 + type(i4_t), dimension(9) :: d_vi4 + type(i4_t), dimension(9) :: d_ri4 + + d_vi1%v = (/(i+10,i=1,9)/) + d_i1%v = reshape((/1_1, -1_1, 2_1, -2_1, 3_1, -3_1, 4_1, & + & -4_1, 5_1/), shape(i1)) + d_ri1 = pack(d_i1,d_i1%v>0,d_vi1) + if (any(d_ri1%v /= (/1_1, 2_1, 3_1, 4_1, 5_1, 16_1, 17_1, 18_1, 19_1/))) & + & call abort + + d_vi4%v = (/(i+10,i=1,9)/) + d_i4%v = reshape((/1_4, -1_4, 2_4, -2_4, 3_4, -3_4, 4_4, & + & -4_4, 5_4/), shape(d_i4)) + d_ri4 = pack(d_i4,d_i4%v>0,d_vi4) + if (any(d_ri4%v /= (/1_4, 2_4, 3_4, 4_4, 5_4, 16_4, 17_4, 18_4, 19_4/))) & + & call abort + vr4 = (/(i+10,i=1,9)/) r4 = reshape((/1.0_4, -3.0_4, 2.1_4, -4.21_4, 1.2_4, 0.98_4, -1.2_4, & & -7.1_4, -9.9_4, 0.3_4 /), shape(r4)) diff --git a/gcc/testsuite/gfortran.dg/intrinsic_spread_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_spread_1.f90 index 1fe09d478bb..04e4c577ac6 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_spread_1.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_spread_1.f90 @@ -25,6 +25,14 @@ program foo complex(kind=8), dimension (10) :: c_8 complex(kind=8), dimension (2, 3) :: ac_8 complex(kind=8), dimension (2, 2, 3) :: bc_8 + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension (10) :: it_4 + type(i4_t), dimension (2, 3) :: at_4 + type(i4_t), dimension (2, 2, 3) :: bt_4 + type(i4_t) :: iv_4 + character (len=200) line1, line2, line3 a_1 = reshape ((/1_1, 2_1, 3_1, 4_1, 5_1, 6_1/), (/2, 3/)) @@ -159,6 +167,17 @@ program foo c_8 = spread((1._8,-1._8),1,10) if (any(c_8 /= (1._8,-1._8))) call abort + + at_4%v = reshape ((/1_4, 2_4, 3_4, 4_4, 5_4, 6_4/), (/2, 3/)) + bt_4 = spread (at_4, 1, 2) + if (any (bt_4%v .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 + iv_4%v = 123_4 + it_4 = spread(iv_4,1,10) + if (any(it_4%v /= 123_4)) call abort + + 9000 format(12I3) 9010 format(12F7.3) 9020 format(25F7.3) diff --git a/gcc/testsuite/gfortran.dg/intrinsic_unpack_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_unpack_1.f90 index 71cce798ca5..47b9aef2e3f 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_unpack_1.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_unpack_1.f90 @@ -10,6 +10,12 @@ program intrinsic_unpack real(kind=8), dimension(3,3) :: ar8, br8 complex(kind=4), dimension(3,3) :: ac4, bc4 complex(kind=8), dimension(3,3) :: ac8, bc8 + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension(3,3) :: at4, bt4 + type(i4_t), dimension(3) :: vt4 + logical, dimension(3, 3) :: mask character(len=500) line1, line2 integer i @@ -116,4 +122,14 @@ program intrinsic_unpack mask, ac8) if (line1 .ne. line2) call abort + at4%v = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + vt4%v = (/2_4, 3_4, 4_4/) + bt4 = unpack (vt4, mask, at4) + if (any (bt4%v .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + call abort + bt4%v = -1 + bt4 = unpack (vt4, mask, i4_t(0_4)) + if (any (bt4%v .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + call abort + end program diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index e5908bb79ca..e228cf6db8c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,37 @@ +2008-04-13 Thomas Koenig + Francois-Xavier Coudert + + PR libfortran/32972 + PR libfortran/32512 + configure.ac: Add test for uintptr_t. + configure: Regenerated. + config.h.in: Regenerated. + * libgfortran.h: GFC_DTYPE_DERIVED_1: New macro. + GFC_DTYPE_DERIVED_2: New macro. + GFC_DTYPE_DERIVED_4: New macro. + GFC_DTYPE_DERIVED_8: New macro. + GFC_DTYPE_DERIVED_16: New macro. + GFC_UNALIGNED_2: New macro. + GFC_UNALIGNED_4: New macro. + GFC_UNALIGNED_8: New macro. + GFC_UNALIGNED_16: New macro. + intptr_t: Define if we don't have it. + uintptr_t: Likewise. + * runtime/backtrace.c (show_backtrace): Use intptr_t. + * intrinsics/signal.c (signal_sub): Likewise. + (signal_sub_int): Likewise. + (alarm_sub_int_i4): Likewise. + * intrinsics/spread_generic.c (spread): Use the integer + routines for handling derived types of sizes 1, 2, 4, 8 and 16 + if the alignment of all pointers is correct. + (spread_scalar): Likewise. + * intrinsics/pack_generic.c (pack): Likewise. + Use GFD_DTYPE_TYPE_SIZE to avoid nested switch statements. + * intrinsics/unpack_generic.c (unpack1): Likewise. + (unpack0): Likewise. + * runtime/in_pack_generic.c (internal_pack): Likewise. + * runtime/in_unpack_generic.c (internal_unpack): Likewise. + 2008-04-09 Jakub Jelinek * io/list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined. diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in index ddf8dd57620..1f291a48e27 100644 --- a/libgfortran/config.h.in +++ b/libgfortran/config.h.in @@ -744,6 +744,9 @@ /* Define to 1 if you have the `ttyname' function. */ #undef HAVE_TTYNAME +/* Define to 1 if the system has the type `uintptr_t'. */ +#undef HAVE_UINTPTR_T + /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H @@ -805,19 +808,19 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION -/* The size of `char', as computed by sizeof. */ +/* The size of a `char', as computed by sizeof. */ #undef SIZEOF_CHAR -/* The size of `int', as computed by sizeof. */ +/* The size of a `int', as computed by sizeof. */ #undef SIZEOF_INT -/* The size of `long', as computed by sizeof. */ +/* The size of a `long', as computed by sizeof. */ #undef SIZEOF_LONG -/* The size of `short', as computed by sizeof. */ +/* The size of a `short', as computed by sizeof. */ #undef SIZEOF_SHORT -/* The size of `void *', as computed by sizeof. */ +/* The size of a `void *', as computed by sizeof. */ #undef SIZEOF_VOID_P /* Define to 1 if you have the ANSI C header files. */ @@ -835,5 +838,5 @@ /* Define for large files, on AIX-style hosts. */ #undef _LARGE_FILES -/* Define to `long int' if does not define. */ +/* Define to `long' if does not define. */ #undef off_t diff --git a/libgfortran/configure b/libgfortran/configure index 4fdae429d74..c1e45c72592 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -18815,6 +18815,71 @@ cat >>confdefs.h <<_ACEOF _ACEOF +fi + +echo "$as_me:$LINENO: checking for uintptr_t" >&5 +echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((uintptr_t *) 0) + return 0; +if (sizeof (uintptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_uintptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_uintptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6 +if test $ac_cv_type_uintptr_t = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_UINTPTR_T 1 +_ACEOF + + fi diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac index a1caf3b47eb..657ca4f6d9e 100644 --- a/libgfortran/configure.ac +++ b/libgfortran/configure.ac @@ -211,6 +211,7 @@ AC_CHECK_FUNCS(backtrace backtrace_symbols) # Check for types AC_CHECK_TYPES([intptr_t]) +AC_CHECK_TYPES([uintptr_t]) # Check libc for getgid, getpid, getuid AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])]) diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 2bd09913f00..e282c916502 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -313,101 +313,147 @@ void pack (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_l1 *mask, const gfc_array_char *vector) { - int type; + index_type type_size; index_type size; - type = GFC_DESCRIPTOR_TYPE (array); - size = GFC_DESCRIPTOR_SIZE (array); + type_size = GFC_DTYPE_TYPE_SIZE(array); - switch(type) + switch(type_size) { - case GFC_DTYPE_INTEGER: - case GFC_DTYPE_LOGICAL: - switch(size) - { - case sizeof (GFC_INTEGER_1): - pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, - (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); - return; + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, + (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); + return; - case sizeof (GFC_INTEGER_2): - pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, - (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); - return; + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; - case sizeof (GFC_INTEGER_4): - pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, - (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); - return; + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: - case sizeof (GFC_INTEGER_8): - pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, - (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); - return; + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); + return; #ifdef HAVE_GFC_INTEGER_16 - case sizeof (GFC_INTEGER_16): - pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, - (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); - return; + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + + pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; #endif - } - case GFC_DTYPE_REAL: - switch(size) - { - case sizeof (GFC_REAL_4): - pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, - (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); - return; + case GFC_DTYPE_REAL_4: + pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, + (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); + return; - case sizeof (GFC_REAL_8): - pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, - (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); - return; + case GFC_DTYPE_REAL_8: + pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, + (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); + return; #ifdef HAVE_GFC_REAL_10 - case sizeof (GFC_REAL_10): - pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, - (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); - return; + case GFC_DTYPE_REAL_10: + pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, + (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); + return; #endif #ifdef HAVE_GFC_REAL_16 - case sizeof (GFC_REAL_16): - pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, - (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); - return; + case GFC_DTYPE_REAL_16: + pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, + (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); + return; #endif - } - case GFC_DTYPE_COMPLEX: - switch(size) - { - case sizeof (GFC_COMPLEX_4): - pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, - (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); - return; + case GFC_DTYPE_COMPLEX_4: + pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, + (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); + return; - case sizeof (GFC_COMPLEX_8): - pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, - (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); - return; + case GFC_DTYPE_COMPLEX_8: + pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, + (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); + return; #ifdef HAVE_GFC_COMPLEX_10 - case sizeof (GFC_COMPLEX_10): - pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, - (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); - return; + case GFC_DTYPE_COMPLEX_10: + pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, + (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); + return; #endif #ifdef HAVE_GFC_COMPLEX_16 - case sizeof (GFC_COMPLEX_16): - pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, - (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); - return; + case GFC_DTYPE_COMPLEX_16: + pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, + (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); + return; #endif + /* For derived types, let's check the actual alignment of the + data pointers. If they are aligned, we can safely call + the unpack functions. */ + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data) + || GFC_UNALIGNED_2(vector->data)) + break; + else + { + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data) + || GFC_UNALIGNED_4(vector->data)) + break; + else + { + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data) + || GFC_UNALIGNED_8(vector->data)) + break; + else + { + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); } + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data) + || GFC_UNALIGNED_16(vector->data)) + break; + else + { + pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; + } +#endif + } + + size = GFC_DESCRIPTOR_SIZE (array); pack_internal (ret, array, mask, vector, size); } diff --git a/libgfortran/intrinsics/signal.c b/libgfortran/intrinsics/signal.c index 27d6222cf4e..bd03f6d1afe 100644 --- a/libgfortran/intrinsics/signal.c +++ b/libgfortran/intrinsics/signal.c @@ -44,12 +44,6 @@ Boston, MA 02110-1301, USA. */ #include -#ifdef HAVE_INTPTR_T -# define INTPTR_T intptr_t -#else -# define INTPTR_T int -#endif - /* SIGNAL subroutine with PROCEDURE as handler */ extern void signal_sub (int *, void (*)(int), int *); iexport_proto(signal_sub); @@ -58,11 +52,11 @@ void signal_sub (int *number, void (*handler)(int), int *status) { #ifdef HAVE_SIGNAL - INTPTR_T ret; + intptr_t ret; if (status != NULL) { - ret = (INTPTR_T) signal (*number, handler); + ret = (intptr_t) signal (*number, handler); *status = (int) ret; } else @@ -84,11 +78,11 @@ void signal_sub_int (int *number, int *handler, int *status) { #ifdef HAVE_SIGNAL - INTPTR_T ptr = *handler, ret; + intptr_t ptr = *handler, ret; if (status != NULL) { - ret = (INTPTR_T) signal (*number, (void (*)(int)) ptr); + ret = (intptr_t) signal (*number, (void (*)(int)) ptr); *status = (int) ret; } else @@ -204,14 +198,14 @@ alarm_sub_int_i4 (int *seconds __attribute__ ((unused)), #if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) if (status != NULL) { - if (signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler) == SIG_ERR) + if (signal (SIGALRM, (void (*)(int)) (intptr_t) *handler) == SIG_ERR) *status = -1; else *status = alarm (*seconds); } else { - signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler); + signal (SIGALRM, (void (*)(int)) (intptr_t) *handler); alarm (*seconds); } #else @@ -234,14 +228,14 @@ alarm_sub_int_i8 (int *seconds __attribute__ ((unused)), #if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) if (status != NULL) { - if (signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler) == SIG_ERR) + if (signal (SIGALRM, (void (*)(int)) (intptr_t) *handler) == SIG_ERR) *status = -1; else *status = alarm (*seconds); } else { - signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler); + signal (SIGALRM, (void (*)(int)) (intptr_t) *handler); alarm (*seconds); } #else diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index 16578f788fc..e50598a97c3 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -281,6 +281,7 @@ spread (gfc_array_char *ret, const gfc_array_char *source, type_size = GFC_DTYPE_TYPE_SIZE(ret); switch(type_size) { + case GFC_DTYPE_DERIVED_1: case GFC_DTYPE_LOGICAL_1: case GFC_DTYPE_INTEGER_1: spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, @@ -361,7 +362,49 @@ spread (gfc_array_char *ret, const gfc_array_char *source, return; #endif + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source->data)) + break; + else + { + spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source->data)) + break; + else + { + spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source->data)) + break; + else + { + spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, + *along, *pncopies); + return; + } + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source->data)) + break; + else + { + spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, + *along, *pncopies); + return; + } +#endif } + spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source)); } @@ -398,6 +441,7 @@ spread_scalar (gfc_array_char *ret, const char *source, type_size = GFC_DTYPE_TYPE_SIZE(ret); switch(type_size) { + case GFC_DTYPE_DERIVED_1: case GFC_DTYPE_LOGICAL_1: case GFC_DTYPE_INTEGER_1: spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source, @@ -478,6 +522,46 @@ spread_scalar (gfc_array_char *ret, const char *source, return; #endif + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source)) + break; + else + { + spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source)) + break; + else + { + spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source)) + break; + else + { + spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, + *along, *pncopies); + return; + } +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source)) + break; + else + { + spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, + *along, *pncopies); + return; + } +#endif } spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret)); diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 145dd350568..82607bd5897 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -196,102 +196,141 @@ void unpack1 (gfc_array_char *ret, const gfc_array_char *vector, const gfc_array_l1 *mask, const gfc_array_char *field) { - int type; + index_type type_size; index_type size; - type = GFC_DESCRIPTOR_TYPE (vector); + type_size = GFC_DTYPE_TYPE_SIZE (vector); size = GFC_DESCRIPTOR_SIZE (vector); - switch(type) + switch(type_size) { - case GFC_DTYPE_INTEGER: - case GFC_DTYPE_LOGICAL: - switch(size) - { - case sizeof (GFC_INTEGER_1): - unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, - mask, (gfc_array_i1 *) field); - return; - - case sizeof (GFC_INTEGER_2): - unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, - mask, (gfc_array_i2 *) field); - return; - - case sizeof (GFC_INTEGER_4): - unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, - mask, (gfc_array_i4 *) field); - return; - - case sizeof (GFC_INTEGER_8): - unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, - mask, (gfc_array_i8 *) field); - return; + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, + mask, (gfc_array_i1 *) field); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (gfc_array_i2 *) field); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (gfc_array_i4 *) field); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (gfc_array_i8 *) field); + return; #ifdef HAVE_GFC_INTEGER_16 - case sizeof (GFC_INTEGER_16): - unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, - mask, (gfc_array_i16 *) field); - return; + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (gfc_array_i16 *) field); + return; #endif - } - case GFC_DTYPE_REAL: - switch (size) - { - case sizeof (GFC_REAL_4): - unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, - mask, (gfc_array_r4 *) field); - return; + case GFC_DTYPE_REAL_4: + unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, + mask, (gfc_array_r4 *) field); + return; - case sizeof (GFC_REAL_8): - unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector, - mask, (gfc_array_r8 *) field); - return; + case GFC_DTYPE_REAL_8: + unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector, + mask, (gfc_array_r8 *) field); + return; #ifdef HAVE_GFC_REAL_10 - case sizeof (GFC_REAL_10): - unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, - mask, (gfc_array_r10 *) field); + case GFC_DTYPE_REAL_10: + unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, + mask, (gfc_array_r10 *) field); return; #endif #ifdef HAVE_GFC_REAL_16 - case sizeof (GFC_REAL_16): - unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, - mask, (gfc_array_r16 *) field); - return; + case GFC_DTYPE_REAL_16: + unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, + mask, (gfc_array_r16 *) field); + return; #endif - } - case GFC_DTYPE_COMPLEX: - switch (size) - { - case sizeof (GFC_COMPLEX_4): - unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, - mask, (gfc_array_c4 *) field); - return; + case GFC_DTYPE_COMPLEX_4: + unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, + mask, (gfc_array_c4 *) field); + return; - case sizeof (GFC_COMPLEX_8): - unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, - mask, (gfc_array_c8 *) field); - return; + case GFC_DTYPE_COMPLEX_8: + unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, + mask, (gfc_array_c8 *) field); + return; #ifdef HAVE_GFC_COMPLEX_10 - case sizeof (GFC_COMPLEX_10): - unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, - mask, (gfc_array_c10 *) field); - return; + case GFC_DTYPE_COMPLEX_10: + unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, + mask, (gfc_array_c10 *) field); + return; #endif #ifdef HAVE_GFC_COMPLEX_16 - case sizeof (GFC_COMPLEX_16): - unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, - mask, (gfc_array_c16 *) field); - return; + case GFC_DTYPE_COMPLEX_16: + unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, + mask, (gfc_array_c16 *) field); + return; #endif + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data) + || GFC_UNALIGNED_2(field->data)) + break; + else + { + unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (gfc_array_i2 *) field); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data) + || GFC_UNALIGNED_4(field->data)) + break; + else + { + unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (gfc_array_i4 *) field); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data) + || GFC_UNALIGNED_8(field->data)) + break; + else + { + unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (gfc_array_i8 *) field); + return; } +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data) + || GFC_UNALIGNED_16(field->data)) + break; + else + { + unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (gfc_array_i16 *) field); + return; + } +#endif } + unpack_internal (ret, vector, mask, field, size, GFC_DESCRIPTOR_SIZE (field)); } @@ -322,102 +361,139 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, { gfc_array_char tmp; - int type; + index_type type_size; index_type size; - type = GFC_DESCRIPTOR_TYPE (vector); + type_size = GFC_DTYPE_TYPE_SIZE (vector); size = GFC_DESCRIPTOR_SIZE (vector); - switch(type) + switch(type_size) { - case GFC_DTYPE_INTEGER: - case GFC_DTYPE_LOGICAL: - switch(size) - { - case sizeof (GFC_INTEGER_1): - unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, - mask, (GFC_INTEGER_1 *) field); - return; - - case sizeof (GFC_INTEGER_2): - unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, - mask, (GFC_INTEGER_2 *) field); - return; - - case sizeof (GFC_INTEGER_4): - unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, - mask, (GFC_INTEGER_4 *) field); - return; - - case sizeof (GFC_INTEGER_8): - unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, - mask, (GFC_INTEGER_8 *) field); - return; + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, + mask, (GFC_INTEGER_1 *) field); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (GFC_INTEGER_2 *) field); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (GFC_INTEGER_4 *) field); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (GFC_INTEGER_8 *) field); + return; #ifdef HAVE_GFC_INTEGER_16 - case sizeof (GFC_INTEGER_16): - unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, - mask, (GFC_INTEGER_16 *) field); - return; + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (GFC_INTEGER_16 *) field); + return; #endif - } + case GFC_DTYPE_REAL_4: + unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, + mask, (GFC_REAL_4 *) field); + return; - case GFC_DTYPE_REAL: - switch(size) - { - case sizeof (GFC_REAL_4): - unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, - mask, (GFC_REAL_4 *) field); - return; - - case sizeof (GFC_REAL_8): - unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector, - mask, (GFC_REAL_8 *) field); - return; + case GFC_DTYPE_REAL_8: + unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector, + mask, (GFC_REAL_8 *) field); + return; #ifdef HAVE_GFC_REAL_10 - case sizeof (GFC_REAL_10): - unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, - mask, (GFC_REAL_10 *) field); - return; + case GFC_DTYPE_REAL_10: + unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, + mask, (GFC_REAL_10 *) field); + return; #endif #ifdef HAVE_GFC_REAL_16 - case sizeof (GFC_REAL_16): - unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, - mask, (GFC_REAL_16 *) field); - return; + case GFC_DTYPE_REAL_16: + unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, + mask, (GFC_REAL_16 *) field); + return; #endif - } - case GFC_DTYPE_COMPLEX: - switch(size) - { - case sizeof (GFC_COMPLEX_4): - unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, - mask, (GFC_COMPLEX_4 *) field); - return; + case GFC_DTYPE_COMPLEX_4: + unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, + mask, (GFC_COMPLEX_4 *) field); + return; - case sizeof (GFC_COMPLEX_8): - unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, - mask, (GFC_COMPLEX_8 *) field); - return; + case GFC_DTYPE_COMPLEX_8: + unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, + mask, (GFC_COMPLEX_8 *) field); + return; #ifdef HAVE_GFC_COMPLEX_10 - case sizeof (GFC_COMPLEX_10): - unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, - mask, (GFC_COMPLEX_10 *) field); - return; + case GFC_DTYPE_COMPLEX_10: + unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, + mask, (GFC_COMPLEX_10 *) field); + return; #endif #ifdef HAVE_GFC_COMPLEX_16 - case sizeof (GFC_COMPLEX_16): - unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, - mask, (GFC_COMPLEX_16 *) field); - return; + case GFC_DTYPE_COMPLEX_16: + unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, + mask, (GFC_COMPLEX_16 *) field); + return; #endif + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data) + || GFC_UNALIGNED_2(field)) + break; + else + { + unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (GFC_INTEGER_2 *) field); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data) + || GFC_UNALIGNED_4(field)) + break; + else + { + unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (GFC_INTEGER_4 *) field); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data) + || GFC_UNALIGNED_8(field)) + break; + else + { + unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (GFC_INTEGER_8 *) field); + return; + } +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data) + || GFC_UNALIGNED_16(field)) + break; + else + { + unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (GFC_INTEGER_16 *) field); + return; } +#endif } + memset (&tmp, 0, sizeof (tmp)); tmp.dtype = 0; tmp.data = field; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 7d329ff311f..c3c67a1ffdc 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -71,6 +71,38 @@ typedef off_t gfc_offset; #endif +/* We use intptr_t and uintptr_t, which may not be always defined in + system headers. */ + +#ifndef HAVE_INTPTR_T +#if __SIZEOF_POINTER__ == __SIZEOF_LONG__ +#define intptr_t long +#elif __SIZEOF_POINTER__ == __SIZEOF_LONG_LONG__ +#define intptr_t long long +#elif __SIZEOF_POINTER__ == __SIZEOF_INT__ +#define intptr_t int +#elif __SIZEOF_POINTER__ == __SIZEOF_SHORT__ +#define intptr_t short +#else +#error "Pointer type with unexpected size" +#endif +#endif + +#ifndef HAVE_UINTPTR_T +#if __SIZEOF_POINTER__ == __SIZEOF_LONG__ +#define uintptr_t unsigned long +#elif __SIZEOF_POINTER__ == __SIZEOF_LONG_LONG__ +#define uintptr_t unsigned long long +#elif __SIZEOF_POINTER__ == __SIZEOF_INT__ +#define uintptr_t unsigned int +#elif __SIZEOF_POINTER__ == __SIZEOF_SHORT__ +#define uintptr_t unsigned short +#else +#error "Pointer type with unexpected size" +#endif +#endif + + /* On mingw, work around the buggy Windows snprintf() by using the one mingw provides, __mingw_snprintf(). We also provide a prototype for __mingw_snprintf(), because the mingw headers currently don't have one. */ @@ -369,6 +401,32 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; | (sizeof(GFC_COMPLEX_16) << GFC_DTYPE_SIZE_SHIFT)) #endif +#define GFC_DTYPE_DERIVED_1 ((GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ + | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT)) +#define GFC_DTYPE_DERIVED_2 ((GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ + | (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT)) +#define GFC_DTYPE_DERIVED_4 ((GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ + | (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT)) +#define GFC_DTYPE_DERIVED_8 ((GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ + | (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT)) +#ifdef HAVE_GFC_INTEGER_16 +#define GFC_DTYPE_DERIVED_16 ((GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT) \ + | (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT)) +#endif + +/* Macros to determine the alignment of pointers. */ + +#define GFC_UNALIGNED_2(x) (((uintptr_t)(x)) & \ + (__alignof__(GFC_INTEGER_2) - 1)) +#define GFC_UNALIGNED_4(x) (((uintptr_t)(x)) & \ + (__alignof__(GFC_INTEGER_4) - 1)) +#define GFC_UNALIGNED_8(x) (((uintptr_t)(x)) & \ + (__alignof__(GFC_INTEGER_8) - 1)) +#ifdef HAVE_GFC_INTEGER_16 +#define GFC_UNALIGNED_16(x) (((uintptr_t)(x)) & \ + (__alignof__(GFC_INTEGER_16) - 1)) +#endif + /* Runtime library include. */ #define stringize(x) expand_macro(x) #define expand_macro(x) # x diff --git a/libgfortran/runtime/backtrace.c b/libgfortran/runtime/backtrace.c index 00605b50d3f..4a3388841f8 100644 --- a/libgfortran/runtime/backtrace.c +++ b/libgfortran/runtime/backtrace.c @@ -43,12 +43,6 @@ Boston, MA 02110-1301, USA. */ #include #endif -#ifdef HAVE_INTPTR_T -# define INTPTR_T intptr_t -#else -# define INTPTR_T int -#endif - #ifdef HAVE_EXECINFO_H #include #endif @@ -158,7 +152,7 @@ show_backtrace (void) /* Write the list of addresses in hexadecimal format. */ for (i = 0; i < depth; i++) - addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (INTPTR_T) trace[i], addr_buf[i], + addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i], sizeof (addr_buf[i])); /* Don't output an error message if something goes wrong, we'll simply diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c index 067cd280e08..79cbbd7df29 100644 --- a/libgfortran/runtime/in_pack_generic.c +++ b/libgfortran/runtime/in_pack_generic.c @@ -51,7 +51,7 @@ internal_pack (gfc_array_char * source) int n; int packed; index_type size; - int type; + index_type type_size; if (source->dim[0].stride == 0) { @@ -59,73 +59,88 @@ internal_pack (gfc_array_char * source) return source->data; } - type = GFC_DESCRIPTOR_TYPE (source); + type_size = GFC_DTYPE_TYPE_SIZE(source); size = GFC_DESCRIPTOR_SIZE (source); - switch (type) + switch (type_size) { - case GFC_DTYPE_INTEGER: - case GFC_DTYPE_LOGICAL: - switch (size) - { - case sizeof (GFC_INTEGER_1): - return internal_pack_1 ((gfc_array_i1 *) source); - - case sizeof (GFC_INTEGER_2): - return internal_pack_2 ((gfc_array_i2 *) source); - - case sizeof (GFC_INTEGER_4): - return internal_pack_4 ((gfc_array_i4 *) source); - - case sizeof (GFC_INTEGER_8): - return internal_pack_8 ((gfc_array_i8 *) source); + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_DERIVED_1: + return internal_pack_1 ((gfc_array_i1 *) source); + + case GFC_DTYPE_INTEGER_2: + case GFC_DTYPE_LOGICAL_2: + return internal_pack_2 ((gfc_array_i2 *) source); + + case GFC_DTYPE_INTEGER_4: + case GFC_DTYPE_LOGICAL_4: + return internal_pack_4 ((gfc_array_i4 *) source); + + case GFC_DTYPE_INTEGER_8: + case GFC_DTYPE_LOGICAL_8: + return internal_pack_8 ((gfc_array_i8 *) source); #if defined(HAVE_GFC_INTEGER_16) - case sizeof (GFC_INTEGER_16): - return internal_pack_16 ((gfc_array_i16 *) source); + case GFC_DTYPE_INTEGER_16: + case GFC_DTYPE_LOGICAL_16: + return internal_pack_16 ((gfc_array_i16 *) source); #endif - } - break; - - case GFC_DTYPE_REAL: - switch (size) - { - case sizeof (GFC_REAL_4): - return internal_pack_r4 ((gfc_array_r4 *) source); + case GFC_DTYPE_REAL_4: + return internal_pack_r4 ((gfc_array_r4 *) source); - case sizeof (GFC_REAL_8): - return internal_pack_r8 ((gfc_array_r8 *) source); + case GFC_DTYPE_REAL_8: + return internal_pack_r8 ((gfc_array_r8 *) source); #if defined (HAVE_GFC_REAL_10) - case sizeof (GFC_REAL_10): - return internal_pack_r10 ((gfc_array_r10 *) source); + case GFC_DTYPE_REAL_10: + return internal_pack_r10 ((gfc_array_r10 *) source); #endif #if defined (HAVE_GFC_REAL_16) - case sizeof (GFC_REAL_16): - return internal_pack_r16 ((gfc_array_r16 *) source); + case GFC_DTYPE_REAL_16: + return internal_pack_r16 ((gfc_array_r16 *) source); #endif - } - case GFC_DTYPE_COMPLEX: - switch (size) - { - case sizeof (GFC_COMPLEX_4): - return internal_pack_c4 ((gfc_array_c4 *) source); - - case sizeof (GFC_COMPLEX_8): - return internal_pack_c8 ((gfc_array_c8 *) source); + case GFC_DTYPE_COMPLEX_4: + return internal_pack_c4 ((gfc_array_c4 *) source); + + case GFC_DTYPE_COMPLEX_8: + return internal_pack_c8 ((gfc_array_c8 *) source); #if defined (HAVE_GFC_COMPLEX_10) - case sizeof (GFC_COMPLEX_10): - return internal_pack_c10 ((gfc_array_c10 *) source); + case GFC_DTYPE_COMPLEX_10: + return internal_pack_c10 ((gfc_array_c10 *) source); #endif #if defined (HAVE_GFC_COMPLEX_16) - case sizeof (GFC_COMPLEX_16): - return internal_pack_c16 ((gfc_array_c16 *) source); + case GFC_DTYPE_COMPLEX_16: + return internal_pack_c16 ((gfc_array_c16 *) source); #endif - } - break; + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(source->data)) + break; + else + return internal_pack_2 ((gfc_array_i2 *) source); + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(source->data)) + break; + else + return internal_pack_4 ((gfc_array_i4 *) source); + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(source->data)) + break; + else + return internal_pack_8 ((gfc_array_i8 *) source); + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(source->data)) + break; + else + return internal_pack_16 ((gfc_array_i16 *) source); +#endif default: break; diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c index 8b51fe92e72..81d1f0485ec 100644 --- a/libgfortran/runtime/in_unpack_generic.c +++ b/libgfortran/runtime/in_unpack_generic.c @@ -49,98 +49,124 @@ internal_unpack (gfc_array_char * d, const void * s) const char *src; int n; int size; - int type; + int type_size; dest = d->data; /* This check may be redundant, but do it anyway. */ if (s == dest || !s) return; - type = GFC_DESCRIPTOR_TYPE (d); - size = GFC_DESCRIPTOR_SIZE (d); - switch (type) + type_size = GFC_DTYPE_TYPE_SIZE (d); + switch (type_size) { - case GFC_DTYPE_INTEGER: - case GFC_DTYPE_LOGICAL: - switch (size) - { - case sizeof (GFC_INTEGER_1): - internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s); - return; + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_DERIVED_1: + internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s); + return; - case sizeof (GFC_INTEGER_2): - internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); - return; + case GFC_DTYPE_INTEGER_2: + case GFC_DTYPE_LOGICAL_2: + internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); + return; - case sizeof (GFC_INTEGER_4): - internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); - return; + case GFC_DTYPE_INTEGER_4: + case GFC_DTYPE_LOGICAL_4: + internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); + return; - case sizeof (GFC_INTEGER_8): - internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); - return; + case GFC_DTYPE_INTEGER_8: + case GFC_DTYPE_LOGICAL_8: + internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); + return; #if defined (HAVE_GFC_INTEGER_16) - case sizeof (GFC_INTEGER_16): - internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); - return; + case GFC_DTYPE_INTEGER_16: + case GFC_DTYPE_LOGICAL_16: + internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); + return; #endif - } - break; - - case GFC_DTYPE_REAL: - switch (size) - { - case sizeof (GFC_REAL_4): - internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s); - return; + case GFC_DTYPE_REAL_4: + internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s); + return; - case sizeof (GFC_REAL_8): - internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s); - return; + case GFC_DTYPE_REAL_8: + internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s); + return; #if defined(HAVE_GFC_REAL_10) - case sizeof (GFC_REAL_10): - internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s); - return; + case GFC_DTYPE_REAL_10: + internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s); + return; #endif #if defined(HAVE_GFC_REAL_16) - case sizeof (GFC_REAL_16): - internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s); - return; + case GFC_DTYPE_REAL_16: + internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s); + return; #endif + case GFC_DTYPE_COMPLEX_4: + internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s); + return; - } + case GFC_DTYPE_COMPLEX_8: + internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s); + return; + +#if defined(HAVE_GFC_COMPLEX_10) + case GFC_DTYPE_COMPLEX_10: + internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s); + return; +#endif - case GFC_DTYPE_COMPLEX: - switch (size) +#if defined(HAVE_GFC_COMPLEX_16) + case GFC_DTYPE_COMPLEX_16: + internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s); + return; +#endif + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(d->data) || GFC_UNALIGNED_2(s)) + break; + else { - case sizeof (GFC_COMPLEX_4): - internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s); + internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s); return; - - case sizeof (GFC_COMPLEX_8): - internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s); + } + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(d->data) || GFC_UNALIGNED_4(s)) + break; + else + { + internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s); return; + } -#if defined(HAVE_GFC_COMPLEX_10) - case sizeof (GFC_COMPLEX_10): - internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s); + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(d->data) || GFC_UNALIGNED_8(s)) + break; + else + { + internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s); return; -#endif + } -#if defined(HAVE_GFC_COMPLEX_16) - case sizeof (GFC_COMPLEX_16): - internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s); +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(d->data) || GFC_UNALIGNED_16(s)) + break; + else + { + internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s); return; + } #endif - } default: break; } + size = GFC_DESCRIPTOR_SIZE (d); + if (d->dim[0].stride == 0) d->dim[0].stride = 1;