Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9359/src/elephant

Modified Files: classindex.lisp serializer.lisp Log Message:

Corrections for SBCL serialization and index testing.

--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 19:19:12 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 21:41:24 1.11 @@ -423,14 +423,28 @@ (next-in-range skey (cons val nil)) nil))))) + +(defmacro do-subsets ((subset subset-size list) &body body) + (let ((place (gensym)) + (i (gensym))) + `(let ((,place ,list) + (,subset nil)) + (loop while ,place do + (setf ,subset nil) + (loop for ,i from 1 upto ,subset-size do + (if (null ,place) (return) + (push (pop ,place) ,subset))) + ,@body)))) + (defun drop-instances (instances &key (sc *store-controller*)) (when instances - (assert (and (consp instances) (< (length instances) 500))) - (with-transaction (:store-controller sc) - (mapc (lambda (instance) - (remove-kv (oid instance) (find-class-index (class-of instance))) - (drop-pobject instance)) - instances)))) - + (assert (consp instances)) + (do-subsets (subset 500 instances) + (with-transaction (:store-controller sc) + (mapc (lambda (instance) + (remove-kv (oid instance) (find-class-index (class-of instance))) + (drop-pobject instance)) + subset))))) +

--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 17:53:44 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 21:41:24 1.4 @@ -84,8 +84,7 @@ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+ ) - ;; +ucs1-symbol+) + (base-string +ucs1-symbol+) (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-symbol+ @@ -105,8 +104,7 @@ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob - (base-string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+ ) - ;; +ucs1-string+ + (base-string +ucs1-string+) (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-string+ @@ -148,8 +146,7 @@ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+ ) - ;; +ucs1-pathname+ + (base-string +ucs1-pathname+) (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-pathname+ @@ -482,8 +479,8 @@

(eval-when (:compile-toplevel :load-toplevel) - (asdf:operate 'asdf:load-op :cl-base64) -) + (asdf:operate 'asdf:load-op :cl-base64)) + (defun ser-deser-equal (x1 &key sc) (let* ( (x1s (serialize-to-base64-string x1))