~ chicken-core (chicken-5) 11014f17d16e50f99d4a54cb7c4927228269c5c7
commit 11014f17d16e50f99d4a54cb7c4927228269c5c7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 15 08:50:29 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 15 08:50:29 2010 -0400
first implementation of pointer vectors
diff --git a/c-backend.scm b/c-backend.scm
index fac2058a..2a33a9b6 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1178,6 +1178,7 @@
[(s32vector nonnull-s32vector) (str "int *")]
[(f32vector nonnull-f32vector) (str "float *")]
[(f64vector nonnull-f64vector) (str "double *")]
+ ((pointer-vector nonnull-pointer-vector) (str "void **"))
[(nonnull-c-string c-string nonnull-c-string* c-string* symbol)
(str "char *")]
[(nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)
@@ -1284,6 +1285,8 @@
((nonnull-f32vector) "C_c_f32vector(")
((f64vector) "C_c_f64vector_or_null(")
((nonnull-f64vector) "C_c_f64vector(")
+ ((pointer-vector) "C_c_pointer_vector_or_null(")
+ ((nonnull-pointer-vector) "C_c_pointer_vector(")
((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")
((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string
nonnull-unsigned-c-string* symbol) "C_c_string(")
diff --git a/chicken.h b/chicken.h
index 5830ae3d..dde32f07 100644
--- a/chicken.h
+++ b/chicken.h
@@ -986,6 +986,7 @@ extern double trunc(double);
#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_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)))
#define C_isnan(f) (!((f) == (f)))
#define C_isinf(f) ((f) == (f) + (f) && (f) != 0.0)
@@ -2033,6 +2034,12 @@ 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;
+}
+
+
C_inline void *C_c_pointer_or_null(C_word x)
{
return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
diff --git a/library.scm b/library.scm
index bb738448..d0bb6dd5 100644
--- a/library.scm
+++ b/library.scm
@@ -3910,6 +3910,10 @@ 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:
@@ -4362,6 +4366,7 @@ EOF
(let ([v (##sys#slot obj 1)])
(##sys#check-range index 0 (##sys#size v) loc)
(##core#inline_allocate ("C_a_i_make_locative" 5) 9 v index weak?) ) ]
+ ;;XXX pointer-vector currently not supported
[else
(##sys#check-range index 0 (fx- (##sys#size obj) 1) loc)
(##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj (fx+ index 1) weak?) ] ) ]
diff --git a/lolevel.scm b/lolevel.scm
index a5f20737..acff3cd3 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -32,7 +32,8 @@
##sys#check-block
##sys#check-become-alist
##sys#check-generic-structure
- ##sys#check-generic-vector )
+ ##sys#check-generic-vector
+ pv-buf-ref pv-buf-set!)
(not inline ipc-hook-0 ##sys#invalid-procedure-call-hook)
(foreign-declare #<<EOF
#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
@@ -647,3 +648,67 @@ EOF
(##sys#check-symbol sym 'global-make-unbound!)
(##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
sym )
+
+
+;;; pointer vectors
+
+(define make-pointer-vector
+ (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?
+ (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#make-structure 'pointer-vector n buf)))))
+
+(define (pointer-vector? x)
+ (##sys#structure? x 'pointer-vector))
+
+(define (pointer-vector . ptrs)
+ (let* ((n (length ptrs))
+ (pv (make-pointer-vector n))
+ (buf (##sys#slot pv 2))) ; buf
+ (do ((ptrs ptrs (cdr ptrs))
+ (i 0 (fx+ i 1)))
+ ((null? ptrs) pv)
+ (pv-buf-set! buf i (car ptrs)))))
+
+(define (pointer-vector-fill! pv ptr)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
+ (when ptr (##sys#check-pointer ptr 'pointer-vector-fill!))
+ (let ((buf (##sys#slot pv 2)) ; buf
+ (n (##sys#slot pv 1))) ; n
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (pv-buf-set! buf i ptr))))
+
+(define pv-buf-ref
+ (foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
+ "C_return(*(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;"))
+
+(define (pointer-vector-set! pv i ptr)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
+ (##sys#check-exact i 'pointer-vector-ref)
+ (##sys#check-range i 0 (##sys#slot pv 1)) ; len
+ (when ptr (##sys#check-pointer ptr 'pointer-vector-set!))
+ (pv-buf-set! (##sys#slot pv 2) i ptr))
+
+(define pointer-vector-ref
+ (getter-with-setter
+ (lambda (pv i)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
+ (##sys#check-exact i 'pointer-vector-ref)
+ (##sys#check-range i 0 (##sys#slot pv 1)) ; len
+ (pv-buf-ref (##sys#slot pv 2) i)) ; buf
+ pointer-vector-set!
+ "(pointer-vector-ref pv i)"))
diff --git a/manual/Foreign type specifiers b/manual/Foreign type specifiers
index c0ff376b..dd98b573 100644
--- a/manual/Foreign type specifiers
+++ b/manual/Foreign type specifiers
@@ -85,6 +85,15 @@ a return value, a {{NULL}} pointer will be returned as {{#f}}.
As {{c-pointer}}, but guaranteed not to be {{#f/NULL}}.
+=== pointer-vector
+
+A vector of foreign pointer objects. {{#f}} is allowed and passed as a
+{{NULL}} pointer.
+
+=== nonnull-pointer-vector
+
+As {{pointer-vector}}, but guaranteed not to be {{#f/NULL}}.
+
=== blob
A blob object, passed as a pointer to its contents. Arguments of type {{blob}}
@@ -253,6 +262,8 @@ double
double
</td></tr><tr><td>[nonnull-]c-pointer</td><td>
void *
+</td></tr><tr><td>[nonnull-]pointer-vector</td><td>
+void **
</td></tr><tr><td>[nonnull-]blob</td><td>
unsigned char *
</td></tr><tr><td>[nonnull-]u8vector</td><td>
diff --git a/manual/Unit lolevel b/manual/Unit lolevel
index 49cbd051..078ee79c 100644
--- a/manual/Unit lolevel
+++ b/manual/Unit lolevel
@@ -307,6 +307,51 @@ is any other kind of pointer-like object {{#f}} is returned. Otherwise an
error is signalled.
+=== Pointer vectors
+
+/Pointer-vectors/ are specialized and space-efficient vectors or
+foreign pointer objects. All procedures defined below that accept
+a pointer object allow {{#f}} as an alternative representation of
+the {{NULL}}-pointer.
+
+==== make-pointer-vector
+
+<procedure>(make-pointer-vector LENGTH [INIT])</procedure>
+
+Creates a pointer-vector of the given length and optionally initializes each
+element to {{INIT}}, which should be a pointer or {{#f}, which represents the
+{{NULL}} pointer.
+
+==== pointer-vector?
+
+<procedure>(pointer-vector? X)</procedure>
+
+Returns {{#t}} if {{X}} is a pointer-vector or {{#f}} otherwise.
+
+==== pointer-vector
+
+<procedure>(pointer-vector POINTER ...)</procedure>
+
+Returns a pointer-vector from the given pointer arguments.
+
+==== pointer-vector-ref
+
+<procedure>(pointer-vector-ref POINTERVECTOR INDEX)</procedure>
+
+Returns the pointer at {{INDEX}} in the given pointer-vector or
+{{#f}} if the element is a {{NULL}}- pointer.
+
+==== pointer-vector-set!
+
+<procedure>(pointer-vector-set! POINTERVECTOR INDEX POINTER)</procedure>
+
+Sets the element at the position {{INDEX}} in the given pointer-vector to
+{{POINTER}}. The alternative syntax
+
+ (set! (pointer-vector-ref POINTERVECTOR INDEX) POINTER)
+
+is also allowed.
+
=== Locatives
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d3105b7a..a18634f7 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -50,7 +50,8 @@
; | deprecated
; BASIC = * | string | symbol | char | number | boolean | list | pair |
; procedure | vector | null | eof | undefined | port |
-; blob | noreturn | pointer | locative | fixnum | float
+; blob | noreturn | pointer | locative | fixnum | float |
+; pointer-vector
; RESULTS = *
; | (VAL1 ...)
diff --git a/support.scm b/support.scm
index 143ef741..a52fefea 100644
--- a/support.scm
+++ b/support.scm
@@ -900,10 +900,10 @@
;;; Create foreign type checking expression:
(define foreign-type-check
- (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
+ (let ((tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
(nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
(nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
- (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
+ (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector))))
(lambda (param type)
(follow-without-loop
type
@@ -926,6 +926,18 @@
(if unsafe
param
`(##sys#foreign-block-argument ,param) ) ]
+ ((pointer-vector)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-pointer-vector-argument ,tmp) )
+ '#f) ) ) )
+ ((nonnull-pointer-vector)
+ (if unsafe
+ param
+ `(##sys#foreign-pointer-vector-argument ,param) ) ]
[(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
(let ([tmp (gensym)])
`(let ([,tmp ,param])
diff --git a/types.db b/types.db
index 1200d696..459a111f 100644
--- a/types.db
+++ b/types.db
@@ -584,6 +584,7 @@
(locative-set! (procedure locative-set! (locative *) *))
(locative? (procedure locative? (*) boolean))
(make-locative (procedure make-locative (* #!optional fixnum) locative))
+(make-pointer-vector (procedure make-pointer-vector (fixnum #!optional pointer) pointer-vector))
(make-record-instance (procedure make-record-instance (* #!rest) *))
(make-weak-locative (procedure make-weak-locative (* #!optional fixnum) locative))
(move-memory! (procedure move-memory! (* * #!optional fixnum fixnum fixnum) *))
@@ -601,15 +602,20 @@
(object-release (procedure object-release (* #!optional (procedure (pointer) *)) *))
(object-size (procedure object-size (*) fixnum))
(object-unevict (procedure object-unevict (* #!optional *) *))
+(pointer+ (procedure pointer+ (pointer fixnum) pointer))
(pointer->address (procedure pointer->address (pointer) number))
-(pointer-like? (procedure pointer-like? (*) boolean))
(pointer->object (procedure pointer->object (pointer) *))
+(pointer-offset deprecated)
+(pointer-like? (procedure pointer-like? (*) boolean))
(pointer-f32-ref (procedure pointer-f32-ref (pointer) number))
(pointer-f32-set! (procedure pointer-f32-set! (pointer number) undefined))
(pointer-f64-ref (procedure pointer-f64-ref (pointer) number))
(pointer-f64-set! (procedure pointer-f64-set! (pointer number) undefined))
-(pointer-offset deprecated)
-(pointer+ (procedure pointer+ (pointer fixnum) pointer))
+(pointer-vector (procedure pointer-vector (#!rest pointer-vector) boolean))
+(pointer-vector? (procedure pointer-vector? (*) boolean))
+(pointer-vector-fill! (procedure pointer-vector-fill! (pointer-vector pointer) undefined))
+(pointer-vector-ref (procedure pointer-vector-ref (pointer-vector fixnum) pointer))
+(pointer-vector-set! (procedure pointer-vector-set! (pointer-vector fixnum pointer) pointer))
(pointer-s16-ref (procedure pointer-s16-ref (pointer) fixnum))
(pointer-s16-set! (procedure pointer-s16-set! (pointer fixnum) undefined))
(pointer-s32-ref (procedure pointer-s32-ref (pointer) number))
Trap