~ chicken-core (chicken-5) d3906e96adaf9dc24e6f514faf2e978810d516c8
commit d3906e96adaf9dc24e6f514faf2e978810d516c8
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Fri Nov 8 16:50:29 2013 +0100
Commit: Mario Domenech Goulart <mario.goulart@gmail.com>
CommitDate: Sat Nov 9 13:30:37 2013 -0200
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.
Signed-off-by: Mario Domenech Goulart <mario.goulart@gmail.com>
diff --git a/chicken.h b/chicken.h
index 5c932ac2..15e2ad6e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1111,21 +1111,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)))
@@ -2239,7 +2240,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 4c26dc72..45b6bfd4 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))))
Trap