~ chicken-core (chicken-5) 887df892c58462824a917f8f606d8ab3c5b64b5c
commit 887df892c58462824a917f8f606d8ab3c5b64b5c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Sep 16 04:24:55 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Sep 16 04:24:55 2010 -0400
fixes to pointer-vector ops
diff --git a/c-platform.scm b/c-platform.scm
index 7056809f..7fee8b53 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -169,7 +169,7 @@
##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword
##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
- ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
+ ##sys#foreign-block-argument ##sys#foreign-struct-wrapper-argument
##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number
##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
@@ -953,7 +953,7 @@
(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")
(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")
(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")
-(rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp")
+(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_argumentp")
(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")
(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")
(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp")
diff --git a/chicken.h b/chicken.h
index dde32f07..0b7e2579 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1829,7 +1829,8 @@ C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_flonum_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_block_argumentp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x) C_regparm; /* OBSOLETE */
+C_fctexport C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_string_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_symbol_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t) C_regparm;
@@ -2036,7 +2037,7 @@ C_inline void *C_srfi_4_vector_or_null(C_word x)
C_inline void *C_c_pointer_vector_or_null(C_word x)
{
- return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
+ return C_truep(x) ? C_data_pointer(C_block_item(x, 2)) : NULL;
}
diff --git a/library.scm b/library.scm
index d0bb6dd5..84807ec4 100644
--- a/library.scm
+++ b/library.scm
@@ -3902,7 +3902,11 @@ EOF
(define (##sys#foreign-fixnum-argument x) (##core#inline "C_i_foreign_fixnum_argumentp" x))
(define (##sys#foreign-flonum-argument x) (##core#inline "C_i_foreign_flonum_argumentp" x))
(define (##sys#foreign-block-argument x) (##core#inline "C_i_foreign_block_argumentp" x))
-(define (##sys#foreign-number-vector-argument t x) (##core#inline "C_i_foreign_number_vector_argumentp" t x))
+
+(define (##sys#foreign-struct-wrapper-argument t x)
+ (##core#inline "C_i_foreign_struct_wrapper_argumentp" t x))
+
+(define ##sys#foreign-number-vector-argument ##sys#foreign-struct-wrapper-argument) ;OBSOLETE
(define (##sys#foreign-string-argument x) (##core#inline "C_i_foreign_string_argumentp" x))
(define (##sys#foreign-symbol-argument x) (##core#inline "C_i_foreign_symbol_argumentp" x))
(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
@@ -3910,10 +3914,6 @@ EOF
(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
(define (##sys#foreign-unsigned-integer-argument x) (##core#inline "C_i_foreign_unsigned_integer_argumentp" x))
-(define (##sys#foreign-pointer-vector-argument x) ; not optimized yet
- (##sys#check-structure x 'pointer-vector)
- x)
-
;;; Low-level threading interface:
diff --git a/lolevel.scm b/lolevel.scm
index 8c02cc81..7c0d745c 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -656,15 +656,15 @@ EOF
(let ((unset (list 'unset)))
(lambda (n #!optional (init unset))
(##sys#check-exact n 'make-pointer-vector)
- (let* ((mul (if (##sys#fudge 3) 8 4)) ; 64-bit?
+ (let* ((mul (##sys#fudge 7)) ; wordsize
(size (fx* n mul))
(buf (##sys#make-blob size)))
(unless (eq? init unset)
(when init
- (##sys#check-pointer init 'make-pointer-vector)
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n))
- (pv-buf-set! buf i init))))
+ (##sys#check-pointer init 'make-pointer-vector))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (pv-buf-set! buf i init)))
(##sys#make-structure 'pointer-vector n buf)))))
(define (pointer-vector? x)
@@ -677,7 +677,9 @@ EOF
(do ((ptrs ptrs (cdr ptrs))
(i 0 (fx+ i 1)))
((null? ptrs) pv)
- (pv-buf-set! buf i (car ptrs)))))
+ (let ((ptr (car ptrs)))
+ (##sys#check-pointer ptr 'pointer-vector)
+ (pv-buf-set! buf i ptr)))))
(define (pointer-vector-fill! pv ptr)
(##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
@@ -690,11 +692,11 @@ EOF
(define pv-buf-ref
(foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
- "C_return(*(C_data_pointer(buf) + i));"))
+ "C_return(*((void **)C_data_pointer(buf) + i));"))
(define pv-buf-set!
(foreign-lambda* void ((scheme-object buf) (unsigned-int i) (c-pointer ptr))
- "*(C_data_pointer(buf) + i) = ptr;"))
+ "*((void **)C_data_pointer(buf) + i) = ptr;"))
(define (pointer-vector-set! pv i ptr)
(##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
diff --git a/runtime.c b/runtime.c
index f3e50097..1a115058 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5570,6 +5570,7 @@ C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
}
+/* OBSOLETE */
C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
{
if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
@@ -5579,6 +5580,15 @@ C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
}
+C_regparm C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
+ barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);
+
+ return x;
+}
+
+
C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
{
if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
diff --git a/support.scm b/support.scm
index a52fefea..d8431392 100644
--- a/support.scm
+++ b/support.scm
@@ -932,25 +932,25 @@
(if ,tmp
,(if unsafe
tmp
- `(##sys#foreign-pointer-vector-argument ,tmp) )
+ `(##sys#foreign-struct-wrapper-argument 'pointer-vector ,tmp) )
'#f) ) ) )
((nonnull-pointer-vector)
(if unsafe
param
- `(##sys#foreign-pointer-vector-argument ,param) ) ]
+ `(##sys#foreign-struct-wrapper-argument 'pointer-vector ,param) ) )
[(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
(let ([tmp (gensym)])
`(let ([,tmp ,param])
(if ,tmp
,(if unsafe
tmp
- `(##sys#foreign-number-vector-argument ',t ,tmp) )
+ `(##sys#foreign-struct-wrapper-argument ',t ,tmp) )
'#f) ) ) ]
[(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector
nonnull-f32vector nonnull-f64vector)
(if unsafe
param
- `(##sys#foreign-number-vector-argument
+ `(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
,param) ) ]
[(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 71d18acf..713e5c52 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -278,6 +278,7 @@
(define pv (make-pointer-vector 42 #f))
(assert (= 42 (pointer-vector-length pv)))
+(assert (not (pointer-vector-ref pv 0)))
(pointer-vector-set! pv 1 (address->pointer 999))
(set! (pointer-vector-ref pv 40) (address->pointer 777))
(assert (not (pointer-vector-ref pv 0)))
@@ -285,19 +286,18 @@
(assert (= (pointer->address (pointer-vector-ref pv 1)) 999))
(assert (= (pointer->address (pointer-vector-ref pv 40)) 777))
(pointer-vector-fill! pv (address->pointer 1))
-(assert (= 1 (pointer-vector-ref pv 0)))
-
-(define pv1
- (foreign-lambda* scheme-object ((pointer-vector pv))
- "C_return(C_mk_bool(pv == NULL));"))
-
-(define pv2
- (foreign-lambda* c-pointer ((pointer-vector pv) (bool f))
- "static void *xx;"
- "if(!f) C_return(xx[ 0 ]);"
- "else pv[ 0 ] = xx;"
- "C_return(xx);"))
-
-(assert (eq? #t (pv1 #f)))
-(define p (pv2 #t))
-(assert (pointer=? p (pv2 #f)))
+(assert (= 1 (pointer->address (pointer-vector-ref pv 0))))
+
+#+(not csi)
+(begin
+ (define pv1
+ (foreign-lambda* bool ((pointer-vector pv))
+ "C_return(pv == NULL);"))
+ (define pv2
+ (foreign-lambda* c-pointer ((pointer-vector pv) (bool f))
+ "static void *xx = (void *)123;"
+ "if(f) pv[ 0 ] = xx;"
+ "C_return(xx);"))
+ (assert (eq? #t (pv1 #f)))
+ (define p (pv2 pv #t))
+ (assert (pointer=? p (pv2 pv #f))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index a17184fc..9be2f8e8 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -104,6 +104,11 @@ diff -bu dwindtst.expected dwindtst.out
echo "*** Skipping \"feeley-dynwind\" for now ***"
# $interpret -s feeley-dynwind.scm
+echo "======================================== lolevel tests ..."
+$interpret -s lolevel-tests.scm
+$compile lolevel-tests.scm
+./a.out
+
echo "======================================== syntax tests ..."
$interpret -s syntax-tests.scm
@@ -198,9 +203,6 @@ $interpret -bnq ec.so ec-tests.scm
echo "======================================== hash-table tests ..."
$interpret -s hash-table-tests.scm
-echo "======================================== lolevel tests ..."
-$interpret -s lolevel-tests.scm
-
echo "======================================== port tests ..."
$interpret -s port-tests.scm
Trap