~ chicken-core (chicken-5) 3c7b16605cdb170bb7c3d4c2b1eb06a8e0cf610f

commit 3c7b16605cdb170bb7c3d4c2b1eb06a8e0cf610f
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 8 05:35:32 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 8 05:35:32 2011 +0200

    added queue-length

diff --git a/data-structures.import.scm b/data-structures.import.scm
index 7328cc2a..fc2f3760 100644
--- a/data-structures.import.scm
+++ b/data-structures.import.scm
@@ -61,6 +61,7 @@
    queue-empty?
    queue-first
    queue-last
+   queue-length
    queue-push-back!
    queue-push-back-list!
    queue-remove!
diff --git a/data-structures.scm b/data-structures.scm
index 8844e160..4cc30a89 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -793,9 +793,13 @@ EOF
 ; is stored in the queue type so that datums can be added in constant
 ; time.
 
-(define (make-queue) (##sys#make-structure 'queue '() '()))
+(define (make-queue) (##sys#make-structure 'queue '() '() 0))
 (define (queue? x) (##sys#structure? x 'queue))
 
+(define (queue-length q)		; thread-safe
+  (##sys#check-structure q 'queue 'queue-length)
+  (##sys#slot q 3))
+
 (define (queue-empty? q)		; thread-safe
   (##sys#check-structure q 'queue 'queue-empty?)
   (eq? '() (##sys#slot q 1)) )
@@ -822,6 +826,7 @@ EOF
     (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
 	  (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
     (##sys#setslot q 2 new-pair) 
+    (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1))
     (##core#undefined) ) )
 
 (define queue-remove!			; thread-safe
@@ -834,6 +839,7 @@ EOF
 	(##sys#setslot q 1 first-cdr)
 	(if (eq? '() first-cdr)
 	    (##sys#setslot q 2 '()) )
+	(##sys#setislot q 3 (fx- (##sys#slot q 3) 1))
 	(##sys#slot first-pair 0) ) ) ) )
 
 (define (queue->list q)
@@ -864,7 +870,8 @@ EOF
   (let ((newlist (cons item (##sys#slot q 1))))
     (##sys#setslot q 1 newlist)
     (if (eq? '() (##sys#slot q 2))
-	(##sys#setslot q 2 newlist))))
+	(##sys#setslot q 2 newlist))
+    (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1))))
 
 ; (queue-push-back-list! queue item-list)
 ; Pushes the items in item-list back onto the queue,
@@ -882,4 +889,5 @@ EOF
 		       '()
 		       (last-pair newlist))))
     (##sys#setslot q 1 newlist)
-    (##sys#setslot q 2 newtail)))
+    (##sys#setslot q 2 newtail)
+    (##sys#setislot q 3 (fx+ (##sys#slot q 3) (##core#inline "C_i_length" itemlist)))))
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index e8388236..0151d122 100644
--- a/manual/Unit data-structures	
+++ b/manual/Unit data-structures	
@@ -149,6 +149,13 @@ Returns a newly created queue.
 Returns {{#t}} if {{X}} is a queue, or {{#f}} otherwise.
 
 
+==== queue-length
+
+<procedure>(queue-length QUEUE)</procedure>
+
+Returns the current number of items stored in {{QUEUE}}.
+
+
 ==== queue->list
 
 <procedure>(queue->list QUEUE)</procedure>
diff --git a/types.db b/types.db
index e1076349..e5154d6e 100644
--- a/types.db
+++ b/types.db
@@ -963,6 +963,10 @@
 
 (queue-first (procedure! queue-first ((struct queue)) *))
 (queue-last (procedure! queue-last ((struct queue)) *))
+
+(queue-length (procedure! queue-length ((struct queue)) fixnum)
+	      (((struct queue)) (##sys#slot #(1) '3)))
+
 (queue-push-back! (procedure! queue-push-back! ((struct queue) *) undefined))
 (queue-push-back-list! (procedure! queue-push-back-list! ((struct queue) list) undefined))
 (queue-remove! (procedure! queue-remove! ((struct queue)) *))