- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[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

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

19 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27429/src/elephant Modified Files: serializer2.lisp Log Message: single-float fix for serializer --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/18 20:40:50 1.31 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/19 20:51:28 1.32 @@ -208,7 +208,6 @@ (short-float (buffer-write-byte +short-float+ bs) (buffer-write-float (coerce frob 'single-float) bs)) - #-(and :lispworks (or :win32 :linux)) (single-float (buffer-write-byte +single-float+ bs) (buffer-write-float frob bs))

1 0

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

19 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv22128 Modified Files: TODO config.sexp ele-bdb.asd elephant.asd Log Message: Path creation changes for win32 (need to remove cl-ppcre dependencies) --- /project/elephant/cvsroot/elephant/TODO 2007/03/19 19:41:35 1.72 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/19 20:35:30 1.73 @@ -11,17 +11,10 @@ TASKS TO GET TO BETA: -Bugs: -- Lispworks/Mac: error in finalize indexed class -- Lispworks/Mac: %oid missing in BDB-BTREE on close -- Lispworks/Mac: fix warning in ensure-class-using-class :around (eql nil) method -- Fix build for Win32 (Frank) - Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) Lisp Support: -- Validate Lispworks on Mac - 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? --- /project/elephant/cvsroot/elephant/config.sexp 2007/02/22 20:19:57 1.7 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/03/19 20:35:30 1.8 @@ -1,11 +1,38 @@ -((:berkeley-db-include-dir . "/opt/local/BerkeleyDB.4.5/") +#+(or sbcl allegro) +((:berkeley-db-include-dir . "/opt/local/include/db45/") (:berkeley-db-lib-dir . "/opt/local/lib/db45/") - (:berkeley-db-lib . "/opt/local/BerkeleyDB.4.5/lib/libDB-4.5.dylib") + (:berkeley-db-lib . "/opt/local/lib/db45/libdb-4.5.dylib") (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") (:pthread-lib . nil) (:clsql-lib . nil) (:compiler . :gcc)) +#+openmcl +((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.5/include/") + (:berkeley-db-lib-dir . "/usr/local/BerkeleyDB.4.5/lib/") + (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.5/lib/libdb-4.5.dylib") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :gcc)) + +#+(and lispworks (not windows)) +((:berkeley-db-include-dir . "/opt/local/include/db45/") + (:berkeley-db-lib-dir . "/opt/local/lib/db45/") + (:berkeley-db-lib . "/opt/local/lib/db45/libdb-4.5.dylib") + (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :gcc)) + +#+(or mswindows windows) +((:berkeley-db-include-dir . "C:/Programme/Oracle/Berkeley DB 4.5.20/include/") + (:berkeley-db-lib-dir . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/") + (:berkeley-db-lib . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/libdb45.dll") + (:berkeley-db-deadlock . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/db_deadlock.exe") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :cygwin)) + ;; Berkeley 4.5 is required, each system will have different settings for ;; these directories, use this as an indication of what each key means ;; --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/18 20:40:50 1.22 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/19 20:35:30 1.23 @@ -27,6 +27,18 @@ ;; 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 "/")))) + (defclass bdb-c-source (elephant-c-source) ()) (defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) @@ -38,18 +50,18 @@ (subseq (pathname-name (make-pathname :defaults (get-config-option :berkeley-db-lib c)) ) 3)) - (defmethod compiler-options ((compiler (eql :cygwin)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c) - (call-next-method) - (list "-ldb45"))) + (list "-ldb45") + (call-next-method))) (defun library-directories (c) (let ((include (make-pathname :defaults (get-config-option :berkeley-db-include-dir c))) (lib (make-pathname :defaults (get-config-option :berkeley-db-lib-dir c)))) #+(or windows mswindows) - (list (format nil "-L\"~A\"" lib) (format nil "-I\"~A\"" include)) + (list (format nil "-L'~A'" (path-for-cygwin lib)) + (format nil "-I'~A'" (path-for-cygwin include))) #-(or windows mswindows) (list (format nil "-L~A" lib) (format nil "-I~A" include)))) --- /project/elephant/cvsroot/elephant/elephant.asd 2007/03/16 14:44:44 1.37 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/03/19 20:35:30 1.38 @@ -97,7 +97,8 @@ #+(or mswindows windows) (progn (let* ((pathname (component-pathname c)) - (directory (directory-namestring pathname)) + (directory #+lispworks (make-pathname :host (pathname-host pathname) :directory (pathname-directory pathname)) + #-lispworks (make-pathname :device (pathname-device pathname) :directory (pathname-directory pathname))) (stdout-lines) (stderr-lines) (exit-status)) (let ((command (format nil "~A ~{~A ~}" (c-compiler-path c)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv8886/tests Modified Files: mop-tests.lisp Log Message: Fixed lispworks MOP support; lispworks is green under Mac OS X --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2007/02/03 04:09:14 1.12 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2007/03/19 19:41:36 1.13 @@ -44,22 +44,27 @@ (slot2 :accessor slot2 :transient t) (slot3 :accessor slot3 :allocation :class :transient t)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'p-class)) (defclass nonp-class () ((slot1 :accessor slot1) (slot2 :accessor slot2) (slot3 :accessor slot3 :allocation :class))) + (finalize-inheritance (find-class 'nonp-class)) (defclass minus-p-class () ((slot1 :accessor slot1 :transient t) (slot2 :accessor slot2) (slot3 :accessor slot3)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'minus-p-class)) (defclass switch-transient () ((slot1 :accessor slot1 :transient t) (slot2 :accessor slot2)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'switch-transient)) (defclass make-persistent () ((slot2 :accessor slot2)) - (:metaclass persistent-metaclass))) + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'make-persistent))) t) (deftest bad-inheritence

1 0