[elephant-cvs] CVS elephant/src/elephant - elephant-cvs@common-lisp.net - mailman3.common-lisp.net

6 Apr 2007

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv21893/src/elephant
Modified Files:
    package.lisp serializer2.lisp 
Added Files:
    pset.lisp 
Log Message:
Trial pset abstraction; fix for debug serialize of complex and more documentation edits

--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/04/01 20:56:19	1.28
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/04/06 02:51:48	1.29
@@ -206,6 +206,8 @@
    #:persistent #:persistent-object #:persistent-metaclass #:defpclass
    #:persistent-collection #:drop-pobject
+   #:pset #:make-pset #:insert-item #:remove-item #:map-pset #:find-item #:pset-list
+
    #:btree #:make-btree
    #:get-value #:remove-kv #:existsp
    #:indexed-btree #:make-indexed-btree 
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/04/04 15:28:29	1.36
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/04/06 02:51:48	1.37
@@ -368,7 +368,8 @@
     (,+object+ . "standard object")
     (,+array+ . "array")
     (,+struct+ . "struct")
-    (,+class+ . "class")))
+    (,+class+ . "class")
+    (,+complex+ . "complex")))
(defun enable-deserializer-tracing ()
   (setf *trace-deserializer* t))
--- /project/elephant/cvsroot/elephant/src/elephant/pset.lisp	2007/04/06 02:51:48	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/pset.lisp	2007/04/06 02:51:48	1.1
(in-package :elephant)
;;
;; Simple implementation of persistent sets
;;
;;
;; Public API
;;
(defclass pset (persistent-collection) ()
  (:documentation "An unordered persistent collection of unique elements according to
                   serializer equal comparison"))
(defgeneric insert-item (item pset)
  (:documentation "Insert a new item into the pset"))
(defgeneric remove-item (item pset)
  (:documentation "Remove specified item from pset"))
(defgeneric map-pset (fn pset)
  (:documentation "Map operator for psets"))
(defgeneric find-item (item pset &key key test)
  (:documentation "Find a an item in the pset using key and test"))
(defgeneric pset-list (pset)
  (:documentation "Convert items of pset into a list for processing"))
(defgeneric build-pset (sc)
  (:documentation "Construct an empty default pset or backend specific pset.
                   This is an internal function used by make-pset"))
;; NOTE: Other operators?
;; - Efficient union, intersection and difference fn's exploiting an underlying
;;   sorted order?
;; - map delete operator?
;;
;; Default implementation based on btrees
;;
(defclass default-pset (pset)
  ((btree :accessor pset-btree :initarg :btree)))
(defmethod build-pset ((sc store-controller))
  "Default pset method; override if backend has better policy"
  (let ((btree (make-btree sc)))
    (make-instance 'default-pset :btree btree :sc sc :from-oid (oid btree))))
(defun make-pset (&key items pset (sc *store-controller*))
  (let ((new-pset (build-pset sc)))
    (when (and items pset)
      (error "Can only initialize a new pset with item list or pset to copy, not both"))
    (when items
      (mapc (lambda (item)
          (insert-item item new-pset))
        items))
    (when pset
      (map-pset (lambda (item)
    	  (insert-item item new-pset))
    	pset))
    new-pset))
(defmethod insert-item (item (pset default-pset))
  (setf (get-value item (pset-btree pset)) t)
  item)
(defmethod remove-item (item (pset default-pset))
  (remove-kv item (pset-btree pset))
  item)
(defmethod find-item (item (pset default-pset) &key key (test #'equal))
  (if (not (or key test))
      (get-value item (pset-btree pset))
      (map-btree (lambda (elt dc)
    	   (declare (ignore dc))
    	   (let ((cmpval (if key (funcall key elt) elt)))
    	     (if (funcall test item cmpval)
    		 (return-from find-item elt))))
    	 (pset-btree pset))))
(defmethod map-pset (fn (pset default-pset))
  (map-btree fn (pset-btree pset))
  pset)
(defmethod pset-list ((pset default-pset))
  (let ((list nil))
    (flet ((collect (item)
         (push item list)))
      (declare (dynamic-extent collect))
      (map-btree (lambda (item dc)
    	   (declare (ignore dc))
    	   (push item list))
    	 (pset-btree pset)))
    list))

    