kmx.io/cl-bordeaux-set

diff --git a/bordeaux-queue.asd b/bordeaux-queue.asd
deleted file mode 100644
index 1e09cbf..0000000
--- a/bordeaux-queue.asd
+++ /dev/null
@@ -1,17 +0,0 @@
-
-(in-package :common-lisp-user)
-
-(defpackage :bordeaux-queue.system
-  (:use :common-lisp :asdf))
-
-(in-package :bordeaux-queue.system)
-
-(defsystem "bordeaux-queue"
-  :name "bordeaux-queue"
-  :author "Thomas de Grivel <thoxdg@gmail.com>"
-  :version "0.1"
-  :description "Re-entrant queue using bordeaux-threads."
-  :depends-on ("bordeaux-threads")
-  :components
-  ((:file "package")
-   (:file "bordeaux-queue" :depends-on ("package"))))
diff --git a/bordeaux-queue.lisp b/bordeaux-queue.lisp
deleted file mode 100644
index e66fba9..0000000
--- a/bordeaux-queue.lisp
+++ /dev/null
@@ -1,114 +0,0 @@
-
-(in-package :bordeaux-queue)
-
-(deftype fixnum+ (&optional (low 0))
-  `(integer ,low ,most-positive-fixnum))
-
-(deftype fixnum* (&optional (low 1))
-  `(integer ,low ,most-positive-fixnum))
-
-(defclass queue ()
-  ((vector :initarg :vector
-	   :reader queue-vector
-	   :type simple-vector)
-   (read-index :initform 0
-	       :accessor queue-read-index
-	       :type fixnum+)
-   (write-index :initform 0
-		:accessor queue-write-index
-		:type fixnum+)
-   (length :initform 0
-	   :accessor queue-length
-	   :type fixnum+)
-   (lock :initform (make-lock 'queue)
-	 :reader queue-lock)))
-
-(defclass queue-blocking-write (queue)
-  ((blocking-write-cv :initform (make-condition-variable
-				 :name "queue blocking write")
-		      :reader queue-blocking-write-cv)))
-
-(defgeneric enqueue-full (queue))
-
-(defgeneric enqueue (queue item &optional blocking))
-
-(defgeneric on-dequeue (queue))
-(defgeneric dequeue (queue))
-(defgeneric dequeue-all (queue))
-
-;;  Initialization
-
-(defun make-queue-vector (size &optional (element-type 't) initial-element)
-  (declare (type fixnum* size))
-  (assert (typep initial-element element-type))
-  (make-array `(,size)
-	      :element-type element-type
-	      :initial-element initial-element))
-
-(defmethod initialize-instance ((q queue) &rest initargs
-				&key size (element-type 't)
-				  initial-element &allow-other-keys)
-  (let ((vector (make-queue-vector size element-type initial-element)))
-    (apply #'call-next-method q (list* :vector vector initargs))))
-
-(defun make-queue (size)
-  (make-instance 'queue :size size))
-
-;;  Enqueue
-
-(defmethod enqueue-full ((q queue))
-  nil)
-
-(defmethod enqueue-full ((q queue-blocking-write))
-  (with-accessors ((lock queue-lock)
-		   (blocking-write-cv queue-blocking-write-cv)) q
-    (condition-wait blocking-write-cv lock)))
-
-(defmethod enqueue ((q queue) item &optional blocking)
-  (assert (typep item (array-element-type (queue-vector q))))
-  (with-accessors ((vector queue-vector)
-		   (write-index queue-write-index)
-		   (length queue-length)
-		   (lock queue-lock)) q
-    (with-lock-held (lock)
-      (labels ((fetch ()
-		 (let ((vector-length (length vector))
-		       (len length))
-		   (cond ((= len vector-length)
-			  (when blocking
-			    (enqueue-full q)
-			    (fetch)))
-			 ((< len vector-length)
-			  (setf write-index (mod (1+ write-index) vector-length)
-				length (1+ len))
-			  t)
-			 (t
-			  (error "Invalid queue length"))))))
-	(fetch)))))
-
-;;  Dequeue
-
-(defmethod on-dequeue ((q queue))
-  nil)
-
-(defmethod on-dequeue ((q queue-blocking-write))
-  (condition-notify (queue-blocking-write-cv q)))
-
-(defmethod dequeue ((q queue))
-  (with-accessors ((vector queue-vector)
-		   (read-index queue-read-index)
-		   (length queue-length)
-		   (lock queue-lock)) q
-    (with-lock-held (lock)
-      (let ((vector-length (length vector))
-	    (len length))
-	(cond ((= 0 len)
-	       (values nil nil))
-	      ((< 0 len)
-	       (let ((item (aref vector read-index)))
-		 (setf read-index (mod (1+ read-index) vector-length)
-		       length (1- len))
-		 (on-dequeue q)
-		 (values item t)))
-	      (t
-	       (error "Invalid queue length")))))))
diff --git a/bordeaux-set.asd b/bordeaux-set.asd
new file mode 100644
index 0000000..74ae2a4
--- /dev/null
+++ b/bordeaux-set.asd
@@ -0,0 +1,17 @@
+
+(in-package :common-lisp-user)
+
+(defpackage :bordeaux-set.system
+  (:use :common-lisp :asdf))
+
+(in-package :bordeaux-set.system)
+
+(defsystem "bordeaux-set"
+  :name "bordeaux-set"
+  :author "Thomas de Grivel <thoxdg@gmail.com>"
+  :version "0.1"
+  :description "Re-entrant set using bordeaux-threads."
+  :depends-on ("bordeaux-threads")
+  :components
+  ((:file "package")
+   (:file "bordeaux-set" :depends-on ("package"))))
diff --git a/bordeaux-set.lisp b/bordeaux-set.lisp
new file mode 100644
index 0000000..1b6ddb2
--- /dev/null
+++ b/bordeaux-set.lisp
@@ -0,0 +1,46 @@
+
+(in-package :bordeaux-set)
+
+(deftype fixnum+ (&optional (low 0))
+  `(integer ,low ,most-positive-fixnum))
+
+(defclass set ()
+  ((hash-table :initarg :hash-table
+	       :initform (make-hash-table)
+	       :reader set-hash-table
+	       :type hash-table)
+   (size :initform 0
+	 :accessor set-size
+	 :type fixnum+)
+   (lock :initform (make-lock "set")
+	 :reader set-lock)))
+
+(defgeneric set-add (set item))
+(defgeneric set-remove (set item))
+(defgeneric set-member-p (set item))
+(defgeneric set-empty-p (set))
+(defgeneric do-set (fn set))
+
+(defmethod set-add ((set set) item)
+  (with-lock-held ((set-lock set))
+    (setf (gethash item (set-hash-table set)) t)
+    (incf (set-size set))))
+
+(defmethod set-remove ((set set) item)
+  (with-lock-held ((set-lock set))
+    (remhash item (set-hash-table set))
+    (decf (set-size set))))
+
+(defmethod set-member-p ((set set) item)
+  (with-lock-held ((set-lock set))
+    (gethash item (set-hash-table set))))
+
+(defmethod set-empty-p ((set set))
+  (= 0 (set-size set)))
+
+(defmethod set-each ((fn function) (set set))
+  (with-lock-held ((set-lock set))
+    (maphash (lambda (key value)
+	       (declare (ignore value))
+	       (funcall fn key))
+	     (set-hash-table set))))
diff --git a/package.lisp b/package.lisp
index 7f73173..051659f 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,10 +1,13 @@
 
 (in-package :common-lisp)
 
-(defpackage :bordeaux-queue
+(defpackage :bordeaux-set
   (:use :bordeaux-threads :common-lisp)
+  (:shadow
+   #:set)
   (:export
-   #:queue
-   #:enqueue
-   #:dequeue
-   #:dequeue-all))
+   #:set
+   #:set-add
+   #:set-remove
+   #:set-member-p
+   #:set-each))