March 2007 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/elephant
by ieslick 23 Mar '07

23 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv18996 Modified Files: collections.lisp Log Message: Doesn't work for different numeric types --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/23 16:10:42 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/23 16:18:59 1.18 @@ -343,7 +343,6 @@ (funcall fn k v)))))) (defun lisp-compare<= (a b) - (assert (eq (type-of a) (type-of b))) (etypecase a (number (<= a b)) (string (string<= a b))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 23 Mar '07

23 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv17228 Modified Files: collections.lisp Log Message: Fix for map-indexed-index bug - I was too aggressive on error checks --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/22 19:46:17 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/23 16:10:42 1.17 @@ -350,8 +350,6 @@ (persistent (<= (oid a) (oid b))))) (defun lisp-compare-eq (a b) - (assert (eq (type-of a) (type-of b))) - (assert (member (type-of a) '(number string persistent null) :test #'subtypep)) (eq a b)) (defmethod map-index (fn (index btree-index) &rest args &key start end)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 23 Mar '07

23 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16270/elephant Modified Files: classindex.lisp controller.lisp metaclasses.lisp package.lisp Log Message: Initial edits for new user manual --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/21 14:29:30 1.30 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/23 16:08:10 1.31 @@ -384,10 +384,18 @@ ;; USER SET API ;; ================= -(defgeneric get-instances-by-class (persistent-metaclass)) -(defgeneric get-instance-by-value (persistent-metaclass slot-name value)) -(defgeneric get-instances-by-value (persistent-metaclass slot-name value)) -(defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) +(defgeneric get-instances-by-class (persistent-metaclass) + (:documentation "Retrieve all instances from the class index as a list of objects")) +(defgeneric get-instance-by-value (persistent-metaclass slot-name value) + (:documentation "Retrieve instances from a slot index by value. Will return only the first + instance if there are duplicates.")) +(defgeneric get-instances-by-value (persistent-metaclass slot-name value) + (:documentation "Returns a list of all instances where the slot value is equal to value.")) +(defgeneric get-instances-by-range (persistent-metaclass slot-name start end) + (:documentation "Returns a list of all instances that match + values between start and end. An argument of + nil to start or end indicates, respectively, + the lowest or highest value in the index")) (defmethod get-instances-by-class ((class symbol)) (get-instances-by-class (find-class class))) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/26 19:12:18 1.39 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/03/23 16:08:10 1.40 @@ -434,7 +434,7 @@ (get-value key (controller-root store-controller))) (defun root-existsp (key &key (store-controller *store-controller*)) - "Get a something from the root." + "Test whether a key exists in the root" (declare (type store-controller store-controller)) (if (existsp key (controller-root store-controller)) t --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/21 14:29:30 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/23 16:08:10 1.13 @@ -43,6 +43,8 @@ ;; (defmacro defpclass (cname parents slot-defs &rest class-opts) + "Shorthand for defining persistent objects. Wraps the main + class definition with persistent-metaclass" `(defclass ,cname ,parents ,slot-defs ,@(add-persistent-metaclass-argument class-opts))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/19 19:41:35 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/23 16:08:10 1.25 @@ -32,10 +32,10 @@ #:store-controller #:controller-root #:controller-class-root #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp - #:get-cached-instance #:flush-instance-cache + #:map-root #:get-cached-instance #:flush-instance-cache #:controller-symbol-cache #:controller-symbol-id-cache #:controller-fast-symbols-p - #:optimize-layout + #:optimize-layout #:drop-pobject #:get-user-configuration-parameter #:database-version @@ -51,7 +51,7 @@ #:initialize-serializer #:with-transaction #:ensure-transaction - #:start-ele-transaction #:commit-transaction #:abort-transaction + #:start-ele-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 23 Mar '07

23 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv15863 Modified Files: sql-controller.lisp Log Message: Fixed CLSQL initialization error --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/03/06 04:43:02 1.22 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/03/23 16:06:43 1.23 @@ -436,10 +436,7 @@ (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key - (recover nil) - (recover-fatal nil) - (thread t)) - (declare (ignore recover recover-fatal thread)) + &allow-other-keys) (insure-thread-table-lock) (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) @@ -448,8 +445,10 @@ (not (probe-file path)))) (con (clsql:connect (cdr (second (controller-spec sc))) :database-type dbtype + :pool t :if-exists :old))) - (setf (slot-value sc 'dbcons) (make-hash-table :test 'equal)) + (setf (controller-db-table sc) (make-hash-table :test 'equal)) + (setf (gethash (thread-hash) (controller-db-table sc)) con) ;; (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it..

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 22 Mar '07

22 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv2395 Modified Files: collections.lisp Log Message: Henrik's re-fix to map-index for get-instances-by-value --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/21 14:29:30 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/22 19:46:17 1.16 @@ -343,12 +343,18 @@ (funcall fn k v)))))) (defun lisp-compare<= (a b) + (assert (eq (type-of a) (type-of b))) (etypecase a (number (<= a b)) (string (string<= a b)) (persistent (<= (oid a) (oid b))))) -(defmethod map-index (fn (index btree-index) &rest args &key (start nil start-supplied-p) (end nil end-supplied-p)) +(defun lisp-compare-eq (a b) + (assert (eq (type-of a) (type-of b))) + (assert (member (type-of a) '(number string persistent null) :test #'subtypep)) + (eq a b)) + +(defmethod map-index (fn (index btree-index) &rest args &key start end) "Like map-btree, but takes a function of three arguments key, value and primary key if you want to get at the primary key value, otherwise use map-btree" (declare (dynamic-extent args) @@ -359,8 +365,7 @@ (labels ((next-range () (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) (if (and exists? - (or (not end-supplied-p) - (null end) + (or (null end) (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) @@ -377,12 +382,13 @@ (next-range)))))) (declare (dynamic-extent next-range next-in-range)) (multiple-value-bind (exists? skey val pkey) - (if (and start-supplied-p (not (null start))) - (cursor-pset-range cur start) - (cursor-pfirst cur)) + (cond ((lisp-compare-eq start end) + (cursor-pset cur start)) + ((null start) + (cursor-pfirst cur)) + (t (cursor-pset-range cur start))) (if (and exists? - (or (not end-supplied-p) - (null end) + (or (null end) (lisp-compare<= skey end))) (progn (funcall fn skey val pkey)

1 0

[elephant-cvs] CVS elephant
by ieslick 21 Mar '07

21 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv26303 Modified Files: TODO Log Message: Beta release TODO --- /project/elephant/cvsroot/elephant/TODO 2007/03/19 20:35:30 1.73 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/21 15:04:59 1.74 @@ -9,20 +9,14 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -TASKS TO GET TO BETA: - -Migration: -- Validate SQL migration 0.6.0->0.6.1 (Robert) +TASKS TO GET TO FINAL RELEASE: Lisp Support: -- Validate Lispworks on PC - Validate OpenMCL pre-1.1 on Mac OS X - Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? - 64-bit lisp verification - Verify db_deadlock for other lisps (launch and kill background program I/F) -TASKS TO GET TO FINAL RELEASE: - Bugs: - Fix any bugs found during BETA

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 21 Mar '07

21 Mar '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv17716/src/memutil Modified Files: memutil.lisp Log Message: Fixes submitted by Henrik; some OpenMCL changes --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/03/16 14:44:46 1.26 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/03/21 14:29:31 1.27 @@ -550,7 +550,7 @@ (let ((needed (+ size 1))) (when (> needed len) (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) size) b) + (setf (deref-array buf '(:array :unsigned-char) size) b) (setf size needed)))) (defun buffer-write-int32 (i bs) @@ -677,7 +677,7 @@ (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position))) + (deref-array (buffer-stream-buffer bs) '(:array :unsigned-char) position))) (defun buffer-read-byte-vector (bs)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 21 Mar '07

21 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv17716/src/elephant Modified Files: classes.lisp classindex.lisp collections.lisp metaclasses.lisp serializer2.lisp Log Message: Fixes submitted by Henrik; some OpenMCL changes --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/19 19:41:35 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/21 14:29:30 1.23 @@ -240,18 +240,19 @@ (defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." - (let ((name (slot-definition-name slot-def))) - (persistent-slot-boundp (get-con instance) instance name))) + (when instance + (let ((name (slot-definition-name slot-def))) + (persistent-slot-boundp (get-con instance) instance name)))) (defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) "Checks if the slot exists in the database." (loop for slot in (class-slots class) - for matches-p = (eq (slot-definition-name slot) slot-name) - until matches-p - finally (return (if (and matches-p - (subtypep (type-of slot) 'persistent-slot-definition)) - (persistent-slot-boundp (get-con instance) instance slot-name) - (call-next-method))))) + for matches-p = (eq (slot-definition-name slot) slot-name) + until matches-p + finally (return (if (and matches-p + (subtypep (type-of slot) 'persistent-slot-definition)) + (persistent-slot-boundp (get-con instance) instance slot-name) + (call-next-method))))) (defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Removes the slot value from the database." --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/19 19:41:35 1.29 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/21 14:29:30 1.30 @@ -430,7 +430,7 @@ (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (declare (type (or fixnum null) start end) - (type string idx-name)) + (type symbol idx-name)) (let ((instances nil)) (declare (type list instances)) (flet ((collector (k v pk) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/18 20:40:50 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/21 14:29:30 1.15 @@ -348,17 +348,20 @@ (string (string<= a b)) (persistent (<= (oid a) (oid b))))) -(defmethod map-index (fn (index btree-index) &rest args &key start end) +(defmethod map-index (fn (index btree-index) &rest args &key (start nil start-supplied-p) (end nil end-supplied-p)) "Like map-btree, but takes a function of three arguments key, value and primary key if you want to get at the primary key value, otherwise use map-btree" - (declare (dynamic-extent args)) + (declare (dynamic-extent args) + (ignorable args)) (let ((sc (get-con index))) (ensure-transaction (:store-controller sc) (with-btree-cursor (cur index) (labels ((next-range () (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) - (if (or (and exists? (not end)) - (and exists? (lisp-compare<= skey end))) + (if (and exists? + (or (not end-supplied-p) + (null end) + (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) @@ -373,12 +376,14 @@ (cursor-pset-range cur key) (next-range)))))) (declare (dynamic-extent next-range next-in-range)) - (multiple-value-bind (exists? skey val pkey) - (if start + (multiple-value-bind (exists? skey val pkey) + (if (and start-supplied-p (not (null start))) (cursor-pset-range cur start) (cursor-pfirst cur)) - (if (or (and exists? (not end)) - (and exists? (lisp-compare<= skey end))) + (if (and exists? + (or (not end-supplied-p) + (null end) + (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/19 19:41:35 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/21 14:29:30 1.12 @@ -304,7 +304,7 @@ (declare (ignore slot-name)) (apply #'make-effective-slot-definition class (compute-effective-slot-definition-initargs - class slot-name direct-slot-definitions))) + class direct-slot-definitions))) #+openmcl (defmethod compute-effective-slot-definition-initargs ((class slots-class) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/19 20:51:28 1.32 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/21 14:29:31 1.33 @@ -168,7 +168,7 @@ (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) (progn - (assert (< #.most-positive-fixnum +2^63+)) + (assert (eq (< #.most-positive-fixnum +2^63+) t)) (if (< (abs frob) +2^31+) (progn (buffer-write-byte +fixnum32+ bs) @@ -343,7 +343,7 @@ (defparameter *tag-table* `((,+fixnum32+ . "fixnum32") - (,+fixnum64+ . "fixnum32") + (,+fixnum64+ . "fixnum64") (,+char+ . "char") (,+short-float+ . "short-float") (,+single-float+ . "single-float")

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 21 Mar '07

21 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv17716/src/db-bdb Modified Files: bdb-transactions.lisp Log Message: Fixes submitted by Henrik; some OpenMCL changes --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/03/04 20:22:47 1.11 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/03/21 14:29:30 1.12 @@ -39,22 +39,21 @@ :txn-nowait txn-nowait :txn-sync txn-sync)))) (declare (type pointer-void txn)) - (let ((result - (multiple-value-list - (let ((*current-transaction* (make-transaction-record sc txn)) - (*store-controller* sc)) - (declare (special *current-transaction* *store-controller*)) - (catch 'transaction - (unwind-protect - (multiple-value-prog1 - (funcall txn-fn) - (db-transaction-commit txn - :txn-nosync txn-nosync - :txn-sync txn-sync) - (setq success t)) - (unless success - (db-transaction-abort txn)))))))) - (unless (and (eq result txn) (not success)) + (let (result) + (let ((*current-transaction* (make-transaction-record sc txn)) + (*store-controller* sc)) + (declare (special *current-transaction* *store-controller*)) + (catch 'transaction + (unwind-protect + (progn + (setf result (multiple-value-list (funcall txn-fn))) + (db-transaction-commit txn + :txn-nosync txn-nosync + :txn-sync txn-sync) + (setq success t)) + (unless success + (db-transaction-abort txn))))) + (when success (return (values-list result))))) finally (error "Too many retries in transaction"))))

1 0

[elephant-cvs] CVS elephant
by ieslick 20 Mar '07

20 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv23926 Modified Files: ele-bdb.asd Log Message: Remove cl-ppcre dependency --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/19 20:35:30 1.23 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/20 02:00:07 1.24 @@ -27,17 +27,17 @@ ;; Compile bdb lib and load libraries ;; + #+(or windows mswindows) (defun path-for-cygwin (path) - "DOS pathname -> cygwin pathname. Replace backslashes with slashes and drive letter with directory. -\"C:\\dir\\\" -> \"/C/dir\" (drive C: must be mounted as /C/ in cgwin." - (let ((result (namestring path))) - (setf result (cl-ppcre:regex-replace "([A-Z]):" - result - #'(lambda (match &rest registers) - (format nil "/~a" (first registers))) - :simple-calls t)) - (setf result (cl-ppcre:regex-replace-all "\\" result "/")))) +"DOS pathname -> cygwin pathname. Replace backslashes with slashes and drive letter with directory. +e.g. \"C:\\dir\\\" -> \"/C/dir/\" (drive C: must be mounted as /C/ in cgwin)" + (let* ((result (namestring path)) + (colon-pos (position #\: result)) + (drive-letter (char result (1- colon-pos)))) + (setf (char result (1- colon-pos)) #\/) + (setf (char result colon-pos) drive-letter) + (substitute #\/ #\\ result))) (defclass bdb-c-source (elephant-c-source) ())

1 0