~ chicken-core (chicken-5) a1763b87d5d1f56998d5a005c3bd903969c358fd

commit a1763b87d5d1f56998d5a005c3bd903969c358fd
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 15 09:06:22 2010 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 15 09:06:22 2010 -0400

    added pv-length and tests

diff --git a/lolevel.import.scm b/lolevel.import.scm
index a61d5ae7..9e9ae290 100644
--- a/lolevel.import.scm
+++ b/lolevel.import.scm
@@ -44,6 +44,7 @@
    locative?
    make-locative
    make-record-instance
+   make-pointer-vector
    make-weak-locative
    move-memory!
    mutate-procedure
@@ -75,6 +76,11 @@
    pointer-s32-set!
    pointer-s8-ref
    pointer-s8-set!
+   pointer-vector
+   pointer-vector?
+   pointer-vector-length
+   pointer-vector-ref
+   pointer-vector-set!
    pointer-tag
    pointer-u16-ref
    pointer-u16-set!
diff --git a/lolevel.scm b/lolevel.scm
index acff3cd3..8c02cc81 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -712,3 +712,7 @@ EOF
      (pv-buf-ref (##sys#slot pv 2) i))	; buf
    pointer-vector-set!
    "(pointer-vector-ref pv i)"))
+
+(define (pointer-vector-length pv)
+  (##sys#check-structure pv 'pointer-vector 'pointer-vector-length)
+  (##sys#slot pv 1))
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index a1ed0f93..82095073 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -273,3 +273,16 @@
 (assert (not (eq? foo new-foo)))
 
 (assert (equal? '(hello 1 2) (foo 1 2)))
+
+; pointer vectors
+
+(define pv (make-pointer-vector 42 #f))
+(assert (= 42 (pointer-vector-length pv)))
+(pointer-vector-set! pv 1 (address->pointer 999))
+(set! (pointer-vector-ref pv 40) (address->pointer 777))
+(assert (not (pointer-vector-ref pv 0)))
+(assert (not (pointer-vector-ref pv 41)))
+(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)))
diff --git a/types.db b/types.db
index 459a111f..61e39bb0 100644
--- a/types.db
+++ b/types.db
@@ -614,6 +614,7 @@
 (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-length (procedure pointer-vector-length (pointer-vector) fixnum))
 (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))