[elephant-cvs] CVS elephant/src/elephant

[ieslick]

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)))
+	  , at 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))