>From 942601945a502b5a70e8e58998e68fd0fa8e532e Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 8 Nov 2013 16:50:29 +0100 Subject: [PATCH] Fix #1059: Use appropriate lolevel accessors for SRFI-4 vectors (not C_u_i_cdr) Also add a few VERY basic tests for srfi-4 vector FFI support. --- chicken.h | 19 ++++++++++--------- tests/compiler-tests.scm | 44 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 53 insertions(+), 10 deletions(-) diff --git a/chicken.h b/chicken.h index 0ef4cc1..8b4768b 100644 --- a/chicken.h +++ b/chicken.h @@ -1112,21 +1112,22 @@ extern double trunc(double); #define C_and(x, y) (C_truep(x) ? (y) : C_SCHEME_FALSE) #define C_c_bytevector(x) ((unsigned char *)C_data_pointer(x)) #define C_c_bytevector_or_null(x) ((unsigned char *)C_data_pointer_or_null(x)) -#define C_c_u8vector(x) ((unsigned char *)C_data_pointer(C_u_i_cdr(x))) +#define C_srfi_4_vector(x) C_data_pointer(C_block_item(x,1)) +#define C_c_u8vector(x) ((unsigned char *)C_srfi_4_vector(x)) #define C_c_u8vector_or_null(x) ((unsigned char *)C_srfi_4_vector_or_null(x)) -#define C_c_s8vector(x) ((char *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_s8vector(x) ((char *)C_srfi_4_vector(x)) #define C_c_s8vector_or_null(x) ((char *)C_srfi_4_vector_or_null(x)) -#define C_c_u16vector(x) ((unsigned short *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_u16vector(x) ((unsigned short *)C_srfi_4_vector(x)) #define C_c_u16vector_or_null(x) ((unsigned short *)C_srfi_4_vector_or_null(x)) -#define C_c_s16vector(x) ((short *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_s16vector(x) ((short *)C_srfi_4_vector(x)) #define C_c_s16vector_or_null(x) ((short *)C_srfi_4_vector_or_null(x)) -#define C_c_u32vector(x) ((C_u32 *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_u32vector(x) ((C_u32 *)C_srfi_4_vector(x)) #define C_c_u32vector_or_null(x) ((C_u32 *)C_srfi_4_vector_or_null(x)) -#define C_c_s32vector(x) ((C_s32 *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_s32vector(x) ((C_s32 *)C_srfi_4_vector(x)) #define C_c_s32vector_or_null(x) ((C_s32 *)C_srfi_4_vector_or_null(x)) -#define C_c_f32vector(x) ((float *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_f32vector(x) ((float *)C_srfi_4_vector(x)) #define C_c_f32vector_or_null(x) ((float *)C_srfi_4_vector_or_null(x)) -#define C_c_f64vector(x) ((double *)C_data_pointer(C_u_i_cdr(x))) +#define C_c_f64vector(x) ((double *)C_srfi_4_vector(x)) #define C_c_f64vector_or_null(x) ((double *)C_srfi_4_vector_or_null(x)) #define C_c_pointer_vector(x) ((void **)C_data_pointer(C_block_item((x), 2))) @@ -2240,7 +2241,7 @@ C_inline void *C_data_pointer_or_null(C_word x) C_inline void *C_srfi_4_vector_or_null(C_word x) { - return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL; + return C_truep(x) ? C_srfi_4_vector(x) : NULL; } diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm index 4c26dc7..45b6bfd 100644 --- a/tests/compiler-tests.scm +++ b/tests/compiler-tests.scm @@ -2,7 +2,7 @@ (import foreign) - +(use srfi-4) ;; test dropping of previous toplevel assignments @@ -240,3 +240,45 @@ ((foreign-lambda* unsigned-integer64 ((unsigned-integer64 x)) "C_return(x);") #xAB54A98CEB1F0AD2))) + +;; #1059: foreign vector types use wrong lolevel accessors, causing +;; paranoid DEBUGBUILD assertions to fail. +(define-syntax srfi-4-vector-length + (lambda (e r c) + (let* ((type (symbol->string (strip-syntax (cadr e)))) + (base-type (string-translate* type '(("nonnull-" . "")))) + (length-procedure-name (string-append base-type "-length"))) + `(,(string->symbol length-procedure-name) ,(caddr e))))) + +(define-syntax s4v-sum + (syntax-rules () + ((_ "integer" type arg) + ((foreign-lambda* int ((type v) (int len)) + "int i, result = 0;" + "for (i = 0; i < len; ++i) {" + " result += (int)v[i];" + "}" + "C_return(result);") arg (srfi-4-vector-length type arg))) + ((_ "float" type arg) + ((foreign-lambda* double ((type v) (int len)) + "int i; double result = 0.0;" + "for (i = 0; i < len; ++i) {" + " result += v[i];" + "}" + "C_return(result);") arg (srfi-4-vector-length type arg))))) +(assert (= 10 (s4v-sum "integer" u8vector '#u8(1 2 3 4)))) +(assert (= 10 (s4v-sum "integer" u16vector '#u16(1 2 3 4)))) +(assert (= 10 (s4v-sum "integer" u32vector '#u32(1 2 3 4)))) +(assert (= 10 (s4v-sum "integer" nonnull-u8vector '#u8(1 2 3 4)))) +(assert (= 10 (s4v-sum "integer" nonnull-u16vector '#u16(1 2 3 4)))) +(assert (= 10 (s4v-sum "integer" nonnull-u32vector '#u32(1 2 3 4)))) +(assert (= -10 (s4v-sum "integer" s8vector '#s8(-1 -2 -3 -4)))) +(assert (= -10 (s4v-sum "integer" s16vector '#s16(-1 -2 -3 -4)))) +(assert (= -10 (s4v-sum "integer" s32vector '#s32(-1 -2 -3 -4)))) +(assert (= -10 (s4v-sum "integer" nonnull-s8vector '#s8(-1 -2 -3 -4)))) +(assert (= -10 (s4v-sum "integer" nonnull-s16vector '#s16(-1 -2 -3 -4)))) +(assert (= -10 (s4v-sum "integer" nonnull-s32vector '#s32(-1 -2 -3 -4)))) +(assert (= 12.0 (s4v-sum "float" f32vector '#f32(1.5 2.5 3.5 4.5)))) +(assert (= 12.0 (s4v-sum "float" f64vector '#f64(1.5 2.5 3.5 4.5)))) +(assert (= 12.0 (s4v-sum "float" nonnull-f32vector '#f32(1.5 2.5 3.5 4.5)))) +(assert (= 12.0 (s4v-sum "float" nonnull-f64vector '#f64(1.5 2.5 3.5 4.5)))) -- 1.8.3.4