September 2004 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: elephant/tests/testsorter.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv28436/tests Added Files: testsorter.lisp Log Message: initiali version Date: Thu Sep 16 06:29:19 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/tests/testsleepycat.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv28278/tests Modified Files: testsleepycat.lisp Log Message: first stab at RT-ifying Date: Thu Sep 16 06:28:05 2004 Author: blee Index: elephant/tests/testsleepycat.lisp diff -u elephant/tests/testsleepycat.lisp:1.1 elephant/tests/testsleepycat.lisp:1.2 --- elephant/tests/testsleepycat.lisp:1.1 Mon Aug 30 23:40:38 2004 +++ elephant/tests/testsleepycat.lisp Thu Sep 16 06:28:05 2004 @@ -1,4 +1,5 @@ +(in-package "ELE-TESTS") (use-package "SLEEPYCAT") (defvar env) @@ -21,28 +22,37 @@ (db-open db :file "foo" :database "bar" :type DB-BTREE :auto-commit t :create t :thread t)) -(defun put-alot (keys) +(deftest prepares + (finishes (prepare)) t) + +(deftest put-alot + (finishes + (loop for key in keys + do + (db-put db key key :auto-commit t))) + t) + +(defun get-alot () (loop for key in keys - with datum = "mydatum" - do - (db-put db key datum :auto-commit t))) + always (string= key (db-get db key)))) + +(deftest put-right (get-alot) t) -(defun put-alot-b (keys) - (with-transaction (:environment env) - (loop for key in keys - do - (db-put db key "mydatum")))) +(deftest put-alot-b + (finishes + (with-transaction (:environment env) + (loop for key in keys + do + (db-put db key key)))) + t) + +(deftest put-right-b (get-alot) t) (defun txn-alot (iters) (loop for i from 1 to iters do (with-transaction (:environment env) (db-put db "mykey" "mydatum")))) - -(defun get-alot (keys) - (loop for key in keys - do - (db-get db key))) (defun get-alot-b (keys) (loop for key in keys

1 0

[elephant-cvs] CVS update: elephant/tests/testserializer.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv27992/tests Modified Files: testserializer.lisp Log Message: buffer-streamified Date: Thu Sep 16 06:27:19 2004 Author: blee Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.4 elephant/tests/testserializer.lisp:1.5 --- elephant/tests/testserializer.lisp:1.4 Sat Sep 4 11:16:11 2004 +++ elephant/tests/testserializer.lisp Thu Sep 16 06:27:19 2004 @@ -1,23 +1,23 @@ (in-package :ele-tests) (defun in-out-value (var) - (serialize var *out-buf*) - (deserialize (buffer-stream-buffer *out-buf*))) + (with-buffer-streams (out-buf) + (deserialize (serialize var out-buf)))) (defun in-out-eq (var) - (serialize var *out-buf*) - (eq var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (eq var (deserialize (serialize var out-buf))))) (defun in-out-equal (var) - (serialize var *out-buf*) - (equal var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (equal var (deserialize (serialize var out-buf))))) (defun in-out-equalp (var) - (serialize var *out-buf*) - (equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (equalp var (deserialize (serialize var out-buf))))) (deftest fixnums - (values + (are-not-null (in-out-equal 0) (in-out-equal -1) (in-out-equal 1) @@ -26,7 +26,7 @@ t t t t t) (deftest fixnum-type-1 - (values + (are-not-null (typep (in-out-value 0) 'fixnum) (typep (in-out-value 1) 'fixnum) (typep (in-out-value -1) 'fixnum) @@ -35,7 +35,7 @@ t t t t t) (deftest bignums - (values + (are-not-null (in-out-equal 10000000000) (in-out-equal -10000000000) (loop for i from 0 to 2000 @@ -53,7 +53,7 @@ t t t t t t t t) (deftest floats - (values + (are-not-null (in-out-equal 0.0) (in-out-equal -0.0) (in-out-equal 0.0d0) @@ -86,7 +86,7 @@ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t) (deftest rationals - (values + (are-not-null (in-out-equal 1/2) (in-out-equal -1/2) (in-out-equal (/ 1 most-positive-fixnum)) @@ -97,20 +97,21 @@ t t t t t t t) (deftest strings - (values + (are-not-null (in-out-equal "") (in-out-equal "this is a test") (in-out-equal (make-string 400 :initial-element (code-char 254)))) t t t) (defun in-out-uninterned-equal (var) - (serialize var *out-buf*) - (let ((new (deserialize (buffer-stream-buffer *out-buf*)))) - (and (equal (symbol-name new) (symbol-name var)) - (equal (symbol-package new) (symbol-package var))))) + (with-buffer-streams (out-buf) + (serialize var out-buf) + (let ((new (deserialize (serialize var out-buf)))) + (and (equal (symbol-name new) (symbol-name var)) + (equal (symbol-package new) (symbol-package var)))))) (deftest symbols - (values + (are-not-null (in-out-equal nil) (in-out-equal T) (in-out-equal 'foobarbazquux) @@ -131,16 +132,15 @@ (deftest pathnames ;;; Given how implementation-specific make-pathname is, ;;; i don't know how to put more portable tests here! - (values + (are-not-null (in-out-equal #p"/usr/local/share/common-lisp/elephant")) t) (deftest conses - (values + (are-not-null (in-out-equal (cons t 100000)) (in-out-equal (list 1 'a "this is a test" 'c 10000 nil 1000 nil)) - (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil)))) - ) + (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil))))) t t t) (deftest hash-tables-1 @@ -150,7 +150,7 @@ (rehash-size (hash-table-rehash-size ht)) (rehash-threshold (hash-table-rehash-threshold ht)) (out (in-out-value ht))) - (values + (are-not-null (eq (hash-table-test out) 'equalp) (= (hash-table-size ht) size) (= (hash-table-rehash-size ht) rehash-size) @@ -169,7 +169,7 @@ (setf (gethash 2 ht) 2.0d0) (setf (gethash 'symbolsymbol ht) "three") (let ((out (in-out-value ht))) - (values + (are-not-null (string= (gethash (cons nil nil) ht) "one") (= (gethash 2 ht) 2.0d0) (string= (gethash 'symbolsymbol ht) "three")))) @@ -179,7 +179,7 @@ (and (subtypep t1 t2) (subtypep t2 t1))) (deftest arrays-1 - (values + (are-not-null (array-has-fill-pointer-p (in-out-value (make-array 200 :fill-pointer t))) (not (array-has-fill-pointer-p @@ -210,7 +210,7 @@ (loop for i from 0 to 99 do (setf (svref svec i) (expt 2 i))) - (values + (are-not-null (in-out-equalp arr) (in-out-equalp vec) (in-out-equalp svec) @@ -279,7 +279,7 @@ (setf (slot-value f 'slot2) f) (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) - (values + (are-not-null (deep-equalp c1 c1) (deep-equalp c2 c2) (deep-equalp l1 l1) @@ -290,11 +290,11 @@ t t t t t t t) (defun in-out-deep-equalp (var) - (serialize var *out-buf*) - (deep-equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (deep-equalp var (deserialize (serialize var out-buf))))) (deftest objects - (values + (are-not-null (in-out-deep-equalp (make-instance 'foo)) (in-out-deep-equalp (make-instance 'bar :slot1 (make-instance 'foo @@ -323,7 +323,7 @@ (setf (slot-value f 'slot2) f) (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) - (values + (are-not-null (in-out-deep-equalp c1) (in-out-deep-equalp c2) (in-out-deep-equalp l1) @@ -342,12 +342,13 @@ (:metaclass persistent-metaclass)) (deftest persistent - (let ((f1 (make-instance 'pfoo)) - (f2 (make-instance 'pfoo :slot1 "this is a string")) - (b1 (make-instance 'pbar :slot2 "another string")) - (b2 (make-instance 'pbar)) - (h (make-instance 'btree))) - (values + (let* ((*auto-commit* t) + (f1 (make-instance 'pfoo)) + (f2 (make-instance 'pfoo :slot1 "this is a string")) + (b1 (make-instance 'pbar :slot2 "another string")) + (b2 (make-instance 'pbar)) + (h (make-instance 'btree))) + (are-not-null (in-out-eq f1) (in-out-eq f2) (in-out-eq b1) @@ -360,4 +361,3 @@ (progn (setf (get-value f2 h) f2) (eq (get-value f2 h) f2)))) t t t t t t t t) - \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/tests/testcollections.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26292/tests Added Files: testcollections.lisp Log Message: test btrees, secondary indices and cursors Date: Thu Sep 16 06:26:37 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/tests/mop-tests.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26181/tests Modified Files: mop-tests.lisp Log Message: updates makunbound Date: Thu Sep 16 06:26:08 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.4 elephant/tests/mop-tests.lisp:1.5 --- elephant/tests/mop-tests.lisp:1.4 Sat Sep 4 11:16:11 2004 +++ elephant/tests/mop-tests.lisp Thu Sep 16 06:26:08 2004 @@ -84,7 +84,7 @@ t) (deftest mixes-right-slots - (values + (are-not-null (typep (find-slot-def 'mix-1 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'mix-1 'slot2) 'ele::transient-slot-definition) (typep (find-slot-def 'mix-1 'slot3) 'ele::transient-slot-definition) @@ -115,7 +115,7 @@ t) (deftest inherit-right-slots - (values + (are-not-null (typep (find-slot-def 'make-persistent2 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'make-persistent2 'slot2) @@ -138,13 +138,15 @@ t) (deftest initform-test - (slot-value (make-instance 'p-initform-test) 'slot1) + (let ((*auto-commit* t)) + (slot-value (make-instance 'p-initform-test) 'slot1)) 10) (deftest initarg-test - (values - (slot-value (make-instance 'p-initform-test-2) 'slot1) - (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)) + (let ((*auto-commit* t)) + (values + (slot-value (make-instance 'p-initform-test-2) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1))) 10 20) (deftest no-eval-initform @@ -160,8 +162,19 @@ (progn (defclass redef () () (:metaclass persistent-metaclass)) (defclass redef () () (:metaclass persistent-metaclass)) - (values (subtypep 'redef 'persistent-object))) + (is-not-null (subtypep 'redef 'persistent-object))) t) -(with-open-store (*testdb-path*) - (do-tests)) +;; i wish i could use slot-makunbound but allegro sux +(deftest makunbound + (let ((p (make-instance 'p-class))) + (with-transaction () + (setf (slot1 p) t) + #-allegro + (slot-makunbound p 'slot1) + #+allegro + (slot-makunbound-using-class (find-class 'p-class) p + (find-slot-def 'p-class 'slot1)) + ) + (signals-condition (slot1 p))) + t) \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26111/tests Modified Files: elephant-tests.lisp Log Message: updates Date: Thu Sep 16 06:25:19 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.2 elephant/tests/elephant-tests.lisp:1.3 --- elephant/tests/elephant-tests.lisp:1.2 Sat Sep 4 11:16:11 2004 +++ elephant/tests/elephant-tests.lisp Thu Sep 16 06:25:19 2004 @@ -44,40 +44,50 @@ (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) (:import-from :ele - *out-buf* + with-buffer-streams serialize - deserialize - buffer-stream-buffer) + deserialize) #+cmu (:import-from :pcl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+sbcl (:import-from :sb-mop finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+allegro (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+openmcl (:import-from :ccl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+lispworks (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) ) (in-package :ele-tests) -(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.1/tests/testdb") + +(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.2/tests/testdb") + +(defun do-all-tests() + (with-open-store (*testdb-path*) + (let ((*auto-commit* nil)) + (do-tests)))) (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) @@ -103,3 +113,11 @@ (progn ,@body) (error () t) (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(defmacro is-not-null (&body body) + `(not (null (progn ,@body)))) + +(defmacro are-not-null (&rest forms) + `(values + ,@(loop for form in forms + collect `(is-not-null ,form)))) \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/src/utils.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv26060/src Modified Files: utils.lisp Log Message: doc-strings buffer-streams to sleepycat.lisp with-transaction defaults to *auto-commit* nil Date: Thu Sep 16 06:23:50 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.5 elephant/src/utils.lisp:1.6 --- elephant/src/utils.lisp:1.5 Sat Sep 4 10:23:30 2004 +++ elephant/src/utils.lisp Thu Sep 16 06:23:49 2004 @@ -42,76 +42,53 @@ (in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI")) -(declaim (inline ;resize-buffer-stream - finish-buffer - buffer-write-byte buffer-write-int buffer-write-uint - buffer-write-float buffer-write-double buffer-write-string - buffer-read-byte buffer-read-fixnum buffer-read-int - buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string) - (type fixnum *lisp-obj-id*) +(declaim (type fixnum *lisp-obj-id*) (type hash-table *circularity-hash*) (type boolean *auto-commit*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; buffer-streams -;;; -;;; a stream-like interface for our buffers; methods are -;;; below. ultimately we might want a gray / simple -stream -;;; for real, for now who cares? - -(defstruct buffer-stream - (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) - (length 0 :type fixnum) - (position 0 :type fixnum)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Thread-local specials (defparameter *store-controller* nil "The store controller which persistent objects talk to.") ;; Specials which control persistent objects -(defvar *auto-commit* T) - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) - -;; Buffers for going in and out of the DB -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) +(defvar *auto-commit* T + "Commit things not in transactions?") ;; Stuff the serializer uses -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) +(defvar *lisp-obj-id* 0 + "Circularity ids for the serializer.") +(defvar *circularity-hash* (make-hash-table :test 'eq) + "Circularity hash for the serializer.") + +#+(or cmu sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0) + "Byte specs on CMUCL, SBCL and Allegro are conses.") ;; TODO: make this for real! (defun run-elephant-thread (thunk) + "Sets the specials (which hopefully are thread-local) to +make the Elephant thread-safe." (let ((*current-transaction* +NULL-VOID+) - (*errno-buffer* (allocate-foreign-object :int 1)) - (*get-buffer* (allocate-foreign-object :char 1)) - (*get-buffer-length* 0) + (sleepycat::*errno-buffer* (allocate-foreign-object :int 1)) + ;; if vector-push-extend et al are thread-safe, this + ;; doesn't need to be thread-local. + (sleepycat::*buffer-streams* + (make-array 0 :adjustable t :fill-pointer t)) (*store-controller* *store-controller*) (*auto-commit* *auto-commit*) - (*out-buf* (make-buffer-stream)) - (*key-buf* (make-buffer-stream)) - (*in-buf* (make-buffer-stream)) (*lisp-obj-id* 0) (*circularity-hash* (make-hash-table :test 'eq)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0))) - (declare (special *current-transaction* *errno-buffer* - *get-buffer* *get-buffer-length* *store-controller* - *auto-commit* *out-buf* *key-buf* *in-buf* + (declare (special *current-transaction* sleepycat::*errno-buffer* + sleepycat::*buffer-streams* + *store-controller* *auto-commit* *lisp-obj-id* *circularity-hash* - #+(or cmu scl sbcl allegro) *resourced-byte-spec*)) + #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk))) @@ -128,6 +105,11 @@ txn-nowait txn-sync (retries 100)) &body body) + "Execute a body with a transaction in place. On success, +the transaction is committed. Otherwise, the transaction is +aborted. If the body deadlocks, the body is re-executed in +a new transaction, retrying a fixed number of iterations. +*auto-commit* is false for the body of the transaction." `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment :parent ,parent @@ -136,7 +118,8 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync :retries ,retries) - ,@body)) + (let ((*auto-commit* nil)) + ,@body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -146,242 +129,70 @@ ;;; flushed from the table too (defun make-cache-table (&rest args) + "Make a values-weak hash table: when a value has been +collected, so are the keys." #+(or cmu sbcl scl) (apply #'make-hash-table args) #+allegro (apply #'make-hash-table :values :weak args) #+lispworks (apply #'make-hash-table :weak-kind :value args) + #+openmcl + (apply #'make-hash-table :weak :value args) #-(or cmu sbcl scl allegro lispworks) (apply #'make-hash-table args) ) +#+openmcl +(defclass cleanup-wrapper () + ((cleanup :accessor cleanup :initarg :cleanup) + (value :accessor value :initarg :value))) + +#+openmcl +(defmethod ccl:terminate ((c cleanup-wrapper)) + (funcall (cleanup c))) + (defun get-cache (key cache) + "Get a value from a cache-table." #+(or cmu sbcl) (let ((val (gethash key cache))) (if val (values (weak-pointer-value val) t) (values nil nil))) - #-(or cmu sbcl scl) + #+openmcl + (let ((wrap (gethash key cache))) + (if wrap (values (value wrap) t) + (values nil nil))) + #+(or allegro lispworks) (gethash key cache) ) (defun make-finalizer (key cache) #+(or cmu sbcl) (lambda () (remhash key cache)) - #+allegro + #+(or allegro openmcl) (lambda (obj) (declare (ignore obj)) (remhash key cache)) ) (defun setf-cache (key cache value) + "Set a value in a cache-table." #+(or cmu sbcl) (let ((w (make-weak-pointer value))) (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) + #+openmcl + (let ((w (make-instance 'cleanup-wrapper :value value + :cleanup (make-finalizer key cache)))) + (ccl:terminate-when-unreachable w) + (setf (gethash key cache) w) + value) #+allegro (progn (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) - #-(or cmu sbcl scl allegro) + #+lispworks (setf (gethash key cache) value) ) (defsetf get-cache setf-cache) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; buffer-stream methods - -(eval-when (:compile-toplevel :load-toplevel) - (defun process-struct-slot-defs (slot-defs struct) - (loop for def in slot-defs - collect (list (first def) (list (second def) struct))))) - -(defmacro with-struct-slots (slot-defs struct &body body) - `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) - ,@body)) - -(defun resize-buffer-stream (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (when (> length len) - (let ((newlen (max length (* len 2)))) - (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) - (copy-bufs newbuf 0 buf 0 len) - (free-foreign-object buf) - (setf buf newbuf) - (setf len newlen) - nil))))) - -(defun finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(defun buffer-write-byte (b bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 8) b)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 1))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) pos) b) - (setf pos needed)))) - -(defun buffer-write-int (i bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (signed-byte 32) i)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-int buf i pos) - (setf pos needed) - nil))) - -(defun buffer-write-uint (u bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 32) u)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-uint buf u pos) - (setf pos needed) - nil))) - -(defun buffer-write-float (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type single-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-float buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-double (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type double-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 8))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-double buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-string (s bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type string s)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let* ((str-bytes (byte-length s)) - (needed (+ pos str-bytes))) - (declare (type fixnum str-bytes needed) - (dynamic-extent str-bytes needed)) - (when (> needed len) - (resize-buffer-stream bs needed)) - (copy-str-to-buf buf pos s 0 str-bytes) - (setf pos needed) - nil))) - -(defun buffer-read-byte (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) - -(defun buffer-read-fixnum (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the fixnum (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-int (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-uint (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-float (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (read-float (buffer-stream-buffer bs) pos))) - -(defun buffer-read-double (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 8)) - (read-double (buffer-stream-buffer bs) pos))) - -(defun buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos length)) - ;; wide!!! - #+(and allegro ics) - (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length - :external-format :unicode) - #+lispworks - (fli:convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :null-terminated-p nil)))

1 0

[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25936/src Modified Files: sleepycat.lisp Log Message: split off berkeley-db doc-strings buffer-streamified cmu pointer arithmetic Date: Thu Sep 16 06:22:41 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.9 elephant/src/sleepycat.lisp:1.10 --- elephant/src/sleepycat.lisp:1.9 Thu Sep 2 16:47:09 2004 +++ elephant/src/sleepycat.lisp Thu Sep 16 06:22:41 2004 @@ -42,20 +42,54 @@ (defpackage sleepycat + (:documentation "A low-level UFFI-based interface to +Berkeley DB / Sleepycat, via the libsleepycat.c wrapper. +Partly intended to be usable outside Elephant, but with some +magic for Elephant. In general there is a 1-1 mapping from +functions here and functions in Sleepycat, so refer to their +documentation for details.") (:use common-lisp uffi) + #+cmu + (:use alien) + #+sbcl + (:use sb-alien) + #+cmu + (:import-from :sys + #:sap+) + #+sbcl + (:import-from :sb-sys + #:sap+) + #+openmcl + (:import-from :ccl + #:byte-length) (:export #:*current-transaction* - #:read-int #:read-uint #:read-float #:read-double - #:write-int #:write-uint #:write-float #:write-double - #:offset-char-pointer #:copy-str-to-buf #:copy-bufs #:byte-length + + #:buffer-stream #:make-buffer-stream #:with-buffer-streams + #:resize-buffer-stream #:resize-buffer-stream-no-copy + #:reset-buffer-stream #:buffer-stream-buffer + #:buffer-write-byte #:buffer-write-int + #:buffer-write-uint #:buffer-write-float #:buffer-write-double + #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum + #:buffer-read-int #:buffer-read-uint #:buffer-read-float + #:buffer-read-double #:buffer-read-string #:byte-length + #:pointer-int #:pointer-void #:array-or-pointer-char + #:db-env-create #:db-env-close #:db-env-open #:db-env-dbremove #:db-env-dbrename #:db-env-remove #:db-env-set-flags #:db-env-get-flags #:db-create #:db-close #:db-open #:db-remove #:db-rename #:db-sync #:db-truncate + #:db-set-flags #:db-get-flags #:db-get-key-buffered #:db-get-buffered #:db-get #:db-put-buffered #:db-put #:db-delete-buffered #:db-delete + #:db-cursor #:db-cursor-close #:db-cursor-delete + #:db-cursor-duplicate + #:db-cursor-move-buffered #:db-cursor-set-buffered + #:db-cursor-get-both-buffered + #:db-cursor-pmove-buffered #:db-cursor-pset-buffered + #:db-cursor-pget-both-buffered #:db-cursor-put-buffered #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free @@ -63,6 +97,7 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-lock-detect #:db-env-get-lock-detect #:db-error #:db-error-errno + #:+NULL-VOID+ #:+NULL-CHAR+ #:DB-BTREE #:DB-HASH #:DB-QUEUE #:DB-RECNO #:DB-UNKNOWN #:DB_KEYEMPTY #:DB_LOCK_DEADLOCK #:DB_LOCK_NOTGRANTED @@ -74,6 +109,10 @@ (in-package "SLEEPYCAT") +#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) + (eval-when (:compile-toplevel :load-toplevel) ;; UFFI ;;(asdf:operate 'asdf:load-op :uffi) @@ -98,14 +137,14 @@ #+(or bsd freebsd) "/usr/local/lib/db42/libdb.so" #+darwin - "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!")) ;; Libsleepycat.so: edit this (unless (uffi:load-foreign-library - "/usr/local/share/common-lisp/elephant-0.1/libsleepycat.so" + "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so" :module "libsleepycat") (error "Couldn't load libsleepycat!")) @@ -123,16 +162,15 @@ (declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double offset-char-pointer copy-str-to-buf copy-bufs - %db-get-key-buffered db-get-key-buffered - %db-get-buffered db-get-buffered db-get - %db-put-buffered db-put-buffered - %db-put db-put - %db-delete db-delete-buffered db-delete - %db-txn-begin db-transaction-begin - %db-txn-abort db-transaction-abort - %db-txn-commit db-transaction-commit - %db-transaction-id - flags)) + ;;resize-buffer-stream + ;;buffer-stream-buffer buffer-stream-size buffer-stream-position + ;;buffer-stream-length + reset-buffer-stream + buffer-write-byte buffer-write-int buffer-write-uint + buffer-write-float buffer-write-double buffer-write-string + buffer-read-byte buffer-read-fixnum buffer-read-int + buffer-read-uint buffer-read-float buffer-read-double + buffer-read-string)) ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -169,81 +207,293 @@ (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) (defconstant DB_LOCK_NOWAIT #x001) +(defconstant DB_DUP #x0000002) +(defconstant DB_DUPSORT #x0000004) -(defconstant DB_GET_BOTH 10) -(defconstant DB_SET_LOCK_TIMEOUT 29) -(defconstant DB_SET_TXN_TIMEOUT 33) - -(defconstant DB_KEYEMPTY -30997) -(defconstant DB_LOCK_DEADLOCK -30995) -(defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) +(defconstant DB_CURRENT 7) +(defconstant DB_FIRST 9) +(defconstant DB_GET_BOTH 10) +(defconstant DB_GET_BOTH_RANGE 12) +(defconstant DB_LAST 17) +(defconstant DB_NEXT 18) +(defconstant DB_NEXT_DUP 19) +(defconstant DB_NEXT_NODUP 20) +(defconstant DB_PREV 25) +(defconstant DB_PREV_NODUP 26) +(defconstant DB_SET 28) +(defconstant DB_SET_RANGE 30) + +(defconstant DB_AFTER 1) +(defconstant DB_BEFORE 3) +(defconstant DB_KEYFIRST 15) +(defconstant DB_KEYLAST 16) + +(defconstant DB_NODUPDATA 21) +(defconstant DB_NOOVERWRITE 22) +(defconstant DB_NOSYNC 23) + +(defconstant DB_POSITION 24) + +(defconstant DB_SET_LOCK_TIMEOUT 29) +(defconstant DB_SET_TXN_TIMEOUT 33) + +(defconstant DB_KEYEMPTY -30997) +(defconstant DB_KEYEXIST -30996) +(defconstant DB_LOCK_DEADLOCK -30995) +(defconstant DB_LOCK_NOTGRANTED -30994) +(defconstant DB_NOTFOUND -30990) -(defvar +NULL-VOID+ (make-null-pointer :void)) -(defvar +NULL-CHAR+ (make-null-pointer :char)) +(defconstant DB_LOCK_DEFAULT 1) +(defconstant DB_LOCK_EXPIRE 2) +(defconstant DB_LOCK_MAXLOCKS 3) +(defconstant DB_LOCK_MINLOCKS 4) +(defconstant DB_LOCK_MINWRITE 5) +(defconstant DB_LOCK_OLDEST 6) +(defconstant DB_LOCK_RANDOM 7) +(defconstant DB_LOCK_YOUNGEST 8) +(defvar +NULL-VOID+ (make-null-pointer :void) + "A null pointer to a void type.") +(defvar +NULL-CHAR+ (make-null-pointer :char) + "A null pointer to a char type.") -;; Buffer management / pointer arithmetic -;; Notes: on CMUCL and Allegro: with-cast-pointer + -;; deref-array is faster than FFI + C pointer arithmetic. -;; however pointer arithmetic is usually consing. OpenMCL -;; supports non-consing pointer arithmentic though. +(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT + :PUT :PUT-ALL :PUT-OBJ :PUT-READ + :TIMEOUT :TRADE :UPGRADE-WRITE)) +(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT + :IWRITE :IREAD :IWR :DIRTY :WWRITE)) -;; TODO: #+openmcl versions which do macptr arith. +(def-struct DB-LOCK + (off :unsigned-int) + (ndx :unsigned-int) + (gen :unsigned-int) + (mode DB-LOCKMODE)) + +#+openmcl +(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) + +(def-struct DB-LOCKREQ + (op DB-LOCKOP) + (mode DB-LOCKMODE) + (timeout :unsigned-int) + (obj (:array :char)) + (lock (* DB-LOCK))) + +#+openmcl +(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) + + +;; Thread local storage (special variables) + +(defvar *current-transaction* +NULL-VOID+ + "The transaction which is currently in effect.") + +(defvar *errno-buffer* (allocate-foreign-object :int 1) + "Resourced space for errno return values.") +(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) + "Vector of buffer-streams, which you can grab / return.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-streams +;;; +;;; a stream-like interface for our buffers; methods are +;;; below. ultimately we might want a gray / simple -stream +;;; for real, for now who cares? + +(defstruct buffer-stream + "A stream-like interface to foreign (alien) char buffers." + (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char) + (size 0 :type fixnum) + (position 0 :type fixnum) + (length 10 :type fixnum)) + +(defun grab-buffer-stream () + "Grab a buffer-stream from the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (if (= (length *buffer-streams*) 0) + (make-buffer-stream) + (vector-pop *buffer-streams*))) + +(defun return-buffer-stream (bs) + "Return a buffer-stream to the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (reset-buffer-stream bs) + (vector-push-extend bs *buffer-streams*)) + +(defmacro with-buffer-streams (names &body body) + "Grab a buffer-stream, executes forms, and returns the +stream to the pool on exit." + `(let ,(loop for name in names collect (list name '(grab-buffer-stream))) + (unwind-protect + (progn ,@body) + (progn + ,@(loop for name in names + collect (list 'return-buffer-stream name)))))) + +;; Buffer management / pointer arithmetic + +;; Notes: on Allegro: with-cast-pointer + deref-array is +;; faster than FFI + C pointer arithmetic. however pointer +;; arithmetic is usually consing. OpenMCL supports +;; non-consing pointer arithmentic though. Check these +;; CMUCL / SBCL things don't cons unless necessary. + +;; TODO: #+openmcl versions which do macptr arith. + +#+(or cmu sbcl) +(defun read-int (buf offset) + "Read a 32-bit signed integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (signed-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))))) + +#+(or cmu sbcl) +(defun read-uint (buf offset) + "Read a 32-bit unsigned integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (unsigned-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))))) + +#+(or cmu sbcl) +(defun read-float (buf offset) + "Read a single-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the single-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))))) + +#+(or cmu sbcl) +(defun read-double (buf offset) + "Read a double-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the double-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))))) + +#+(or cmu sbcl) +(defun write-int (buf num offset) + "Write a 32-bit signed integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (signed-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))) num)) + +#+(or cmu sbcl) +(defun write-uint (buf num offset) + "Write a 32-bit unsigned integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (unsigned-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))) num)) + +#+(or cmu sbcl) +(defun write-float (buf num offset) + "Write a single-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type single-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))) num)) + +#+(or cmu sbcl) +(defun write-double (buf num offset) + "Write a double-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type double-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))) num)) + +#+(or cmu sbcl) +(defun offset-char-pointer (p offset) + "Pointer arithmetic." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) p) + (type fixnum offset)) + (sap-alien (sap+ (alien-sap p) offset) (* char))) +#-(or cmu sbcl) (def-function ("read_int" read-int) ((buf array-or-pointer-char) (offset :int)) :returning :int) +#-(or cmu sbcl) (def-function ("read_uint" read-uint) ((buf array-or-pointer-char) (offset :int)) :returning :unsigned-int) +#-(or cmu sbcl) (def-function ("read_float" read-float) ((buf array-or-pointer-char) (offset :int)) :returning :float) +#-(or cmu sbcl) (def-function ("read_double" read-double) ((buf array-or-pointer-char) (offset :int)) :returning :double) +#-(or cmu sbcl) (def-function ("write_int" write-int) ((buf array-or-pointer-char) (num :int) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_uint" write-uint) ((buf array-or-pointer-char) (num :unsigned-int) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_float" write-float) ((buf array-or-pointer-char) (num :float) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_double" write-double) ((buf array-or-pointer-char) (num :double) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("offset_charp" offset-char-pointer) ((p array-or-pointer-char) (offset :int)) :returning array-or-pointer-char) ;; Allegro and Lispworks use 16-bit unicode characters +#+(or cmu sbcl allegro lispworks) (defmacro byte-length (s) + "Return the number of bytes of the internal representation +of a string." #+(or lispworks (and allegro ics)) `(let ((l (length ,s))) (+ l l)) #-(or lispworks (and allegro ics)) @@ -274,6 +524,7 @@ ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) + "Copy a string to a foreign buffer. From Gary Byers." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -287,6 +538,7 @@ ;; Lisp version, for kicks. this assumes 8-bit chars! #+(not (or cmu sbcl scl allegro openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) + "Copy a string to a foreign buffer." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -313,36 +565,240 @@ (length :int)) :returning :void) -;; Thread local storage (special variables) -(declaim (type array-or-pointer-char *get-buffer*) - (type fixnum *get-buffer-length*)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-stream functions + +(eval-when (:compile-toplevel) + (defun process-struct-slot-defs (slot-defs struct) + (loop for def in slot-defs + collect (list (first def) (list (second def) struct))))) + +(defmacro with-struct-slots (slot-defs struct &body body) + `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) + ,@body)) + +(defun resize-buffer-stream (bs length) + "Resize the underlying buffer of a buffer-stream, copying the old data." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + ;; technically we just need to copy from position to size..... + (copy-bufs newbuf 0 buf 0 size) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) + +(defun resize-buffer-stream-no-copy (bs length) + "Resize the underlying buffer of a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) -(defvar *current-transaction* +NULL-VOID+) +(defun reset-buffer-stream (bs) + "'Empty' the buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (setf (buffer-stream-size bs) 0) + (setf (buffer-stream-position bs) 0)) -(defvar *errno-buffer* (allocate-foreign-object :int 1)) +(defun buffer-write-byte (b bs) + "Write a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 8) b)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 1))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (setf (deref-array buf '(:array :char) size) b) + (setf size needed)))) -(defvar *get-buffer* (allocate-foreign-object :char 1)) -(defvar *get-buffer-length* 0) +(defun buffer-write-int (i bs) + "Write a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (signed-byte 32) i)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-int buf i size) + (setf size needed) + nil))) -(defun resize-get-buffer (length) - (declare (optimize (speed 3) (safety 0) (space 0)) +(defun buffer-write-uint (u bs) + "Write a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 32) u)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-uint buf u size) + (setf size needed) + nil))) + +(defun buffer-write-float (d bs) + "Write a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type single-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-float buf d size) + (setf size needed) + nil))) + +(defun buffer-write-double (d bs) + "Write a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type double-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-double buf d size) + (setf size needed) + nil))) + +(defun buffer-write-string (s bs) + "Write the underlying bytes of a string. On Unicode +Lisps, this is a 16-bit operation." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type string s)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let* ((str-bytes (byte-length s)) + (needed (+ size str-bytes))) + (declare (type fixnum str-bytes needed) + (dynamic-extent str-bytes needed)) + (when (> needed len) + (resize-buffer-stream bs needed)) + (copy-str-to-buf buf size s 0 str-bytes) + (setf size needed) + nil))) + +(defun buffer-read-byte (bs) + "Read a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (incf (buffer-stream-position bs)) + (deref-array (buffer-stream-buffer bs) '(:array :char) position))) + +(defun buffer-read-fixnum (bs) + "Read a 32-bit signed integer, which is assumed to be a fixnum." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the fixnum (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-int (bs) + "Read a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-uint (bs) + "Read a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position)))) + +(defun buffer-read-float (bs) + "Read a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (read-float (buffer-stream-buffer bs) position))) + +(defun buffer-read-double (bs) + "Read a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 8)) + (read-double (buffer-stream-buffer bs) position))) + +(defun buffer-read-string (bs length) + "Read a string. On Unicode Lisps this is a 16-bit operation!" + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) (type fixnum length)) - (if (< length *get-buffer-length*) - (values *get-buffer* *get-buffer-length*) - (let ((newlen (max length (* *get-buffer-length* 2)))) - (declare (type fixnum newlen)) - (setq *get-buffer-length* newlen) - (free-foreign-object *get-buffer*) - (setq *get-buffer* (allocate-foreign-object :char newlen)) - (values *get-buffer* *get-buffer-length*)))) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position length)) + ;; wide!!! + #+(and allegro ics) + (excl:native-to-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length + :external-format :unicode) + #+lispworks + (fli:convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :external-format :unicode :null-terminated-p nil) + #-(or lispworks (and allegro ics)) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :null-terminated-p nil))) ;; Wrapper macro -- handles errno return values ;; makes flags into keywords ;; makes keyword args, cstring wrappers -(eval-when (:compile-toplevel :load-toplevel) +(eval-when (:compile-toplevel) (defun make-wrapper-args (args flags keys) (if (or flags keys) (append (remove-keys (remove 'flags args) keys) @@ -378,6 +834,7 @@ (defmacro wrap-errno (names args &key (keys nil) (flags nil) (cstrings nil) (outs 1) (declarations nil) + (documentation nil) (transaction nil)) (let ((wname (if (listp names) (first names) names)) (fname (if (listp names) (second names) @@ -388,7 +845,8 @@ (if (> outs 1) (let ((out-args (make-out-args outs))) `(defun ,wname ,wrapper-args - ,@(if declarations (list declarations) (values)) + ,@(if documentation (list documentation) (values)) + ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (multiple-value-bind ,out-args (,fname ,@fun-args) @@ -399,10 +857,11 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (throw 'transaction ,transaction))) (values)) (t (error 'db-error :errno ,errno)))))))) `(defun ,wname ,wrapper-args + ,@(if documentation (list documentation) (values)) ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (let ((,errno (,fname ,@fun-args))) @@ -412,769 +871,71 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (throw 'transaction ,transaction))) (values)) (t (error 'db-error :errno ,errno))))))))) +(defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log + init-mpool init-rep init-txn recover recover-fatal lockdown + private system-mem thread force dirty-read create excl nommap + rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait + dup dup-sort current first get-both get-both-range last next + next-dup next-nodup prev prev-nodup set set-range + after before keyfirst keylast + no-dup-data no-overwrite nosync position set-lock-timeout + set-transaction-timeout) + (let ((flags (gensym))) + `(let ((,flags 0)) + (declare (type fixnum ,flags)) + ,@(when auto-commit `((when ,auto-commit (setq ,flags (logior ,flags DB_AUTO_COMMIT))))) + ,@(when joinenv `((when ,joinenv (setq ,flags (logior ,flags DB_JOINENV))))) + ,@(when init-cdb `((when ,init-cdb (setq ,flags (logior ,flags DB_INIT_CDB))))) + ,@(when init-lock `((when ,init-lock (setq ,flags (logior ,flags DB_INIT_LOCK))))) + ,@(when init-log `((when ,init-log (setq ,flags (logior ,flags DB_INIT_LOG))))) + ,@(when init-mpool `((when ,init-mpool (setq ,flags (logior ,flags DB_INIT_MPOOL))))) + ,@(when init-rep `((when ,init-rep (setq ,flags (logior ,flags DB_INIT_REP))))) + ,@(when init-txn `((when ,init-txn (setq ,flags (logior ,flags DB_INIT_TXN))))) + ,@(when recover `((when ,recover (setq ,flags (logior ,flags DB_RECOVER))))) + ,@(when recover-fatal `((when ,recover-fatal (setq ,flags (logior ,flags DB_RECOVER_FATAL))))) + ,@(when lockdown `((when ,lockdown (setq ,flags (logior ,flags DB_LOCKDOWN))))) + ,@(when private `((when ,private (setq ,flags (logior ,flags DB_PRIVATE))))) + ,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM))))) + ,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD))))) + ,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE))))) + ,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) + ,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE))))) + ,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL))))) + ,@(when nommap `((when ,nommap (setq ,flags (logior ,flags DB_NOMMAP))))) + ,@(when rdonly `((when ,rdonly (setq ,flags (logior ,flags DB_RDONLY))))) + ,@(when truncate `((when ,truncate (setq ,flags (logior ,flags DB_TRUNCATE))))) + ,@(when txn-nosync `((when ,txn-nosync (setq ,flags (logior ,flags DB_TXN_NOSYNC))))) + ,@(when txn-nowait `((when ,txn-nowait (setq ,flags (logior ,flags DB_TXN_NOWAIT))))) + ,@(when txn-sync `((when ,txn-sync (setq ,flags (logior ,flags DB_TXN_SYNC))))) + ,@(when lock-nowait `((when ,lock-nowait (setq ,flags (logior ,flags DB_LOCK_NOWAIT))))) + ,@(when dup `((when ,dup (setq ,flags (logior ,flags DB_DUP))))) + ,@(when dup-sort `((when ,dup-sort (setq ,flags (logior ,flags DB_DUPSORT))))) + ,@(when current `((when ,current (setq ,flags (logior ,flags DB_CURRENT))))) + ,@(when first `((when ,first (setq ,flags (logior ,flags DB_FIRST))))) + ,@(when get-both `((when ,get-both (setq ,flags (logior ,flags DB_GET_BOTH))))) + ,@(when get-both-range `((when ,get-both-range (setq ,flags (logior ,flags DB_GET_BOTH_RANGE))))) + ,@(when last `((when ,last (setq ,flags (logior ,flags DB_LAST))))) + ,@(when next `((when ,next (setq ,flags (logior ,flags DB_NEXT))))) + ,@(when next-dup `((when ,next-dup (setq ,flags (logior ,flags DB_NEXT_DUP))))) + ,@(when next-nodup `((when ,next-nodup (setq ,flags (logior ,flags DB_NEXT_NODUP))))) + ,@(when prev `((when ,prev (setq ,flags (logior ,flags DB_PREV))))) + ,@(when prev-nodup `((when ,prev-nodup (setq ,flags (logior ,flags DB_PREV_NODUP))))) + ,@(when set `((when ,set (setq ,flags (logior ,flags DB_SET))))) + ,@(when set-range `((when ,set-range (setq ,flags (logior ,flags DB_SET_RANGE))))) + ,@(when after `((when ,after (setq ,flags (logior ,flags DB_AFTER))))) + ,@(when before `((when ,before (setq ,flags (logior ,flags DB_BEFORE))))) + ,@(when keyfirst `((when ,keyfirst (setq ,flags (logior ,flags DB_KEYFIRST))))) + ,@(when keylast `((when ,keylast (setq ,flags (logior ,flags DB_KEYLAST))))) + ,@(when no-dup-data `((when ,no-dup-data (setq ,flags (logior ,flags DB_NODUPDATA))))) + ,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE))))) + ,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC))))) + ,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION))))) + ,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT))))) + ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) + ,flags))) -;; Environment - -(def-function ("db_env_cr" %db-env-create) - ((flags :unsigned-int) - (errno :int :out)) - :returning :pointer-void) - -(defun db-env-create () - (multiple-value-bind (env errno) - (%db-env-create 0) - (declare (type fixnum errno)) - (if (= errno 0) - env - (error 'db-error :errno errno)))) - -(def-function ("db_env_close" %db-env-close) - ((dbenvp :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-close (dbenvp flags)) - -(def-function ("db_env_open" %db-env-open) - ((dbenvp :pointer-void) - (home :cstring) - (flags :unsigned-int) - (mode :int)) - :returning :int) - -(wrap-errno db-env-open (dbenvp home flags mode) - :flags (joinenv init-cdb init-lock init-log - init-mpool init-rep init-txn - recover recover-fatal create - lockdown private system-mem thread) - :keys ((mode #o640)) - :cstrings (home)) - -(def-function ("db_env_dbremove" %db-env-dbremove) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbremove (env transaction file database flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_env_dbrename" %db-env-dbrename) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbrename (env transaction file database newname flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database newname) - :transaction transaction) - -(def-function ("db_env_remove" %db-env-remove) - ((env :pointer-void) - (home :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-remove (env home flags) :flags (force) - :cstrings (home)) - -(def-function ("db_env_set_flags" %db-env-set-flags) - ((env :pointer-void) - (flags :unsigned-int) - (onoff :int)) - :returning :int) - -(wrap-errno db-env-set-flags (env flags onoff) - :flags (auto-commit nommap txn-nosync)) - -(def-function ("db_env_get_flags" %db-env-get-flags) - ((env :pointer-void) - (flags :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-get-flags (env) :outs 2) - - -;; Database - -(def-function ("db_cr" %db-create) - ((dbenv :pointer-void) - (flags :unsigned-int) - (errno :int :out)) - :returning :pointer-void) - -(defun db-create (&optional (dbenv +NULL-VOID+)) - (multiple-value-bind (db errno) - (%db-create dbenv 0) - (declare (type fixnum errno)) - (if (= errno 0) - db - (error 'db-error :errno errno)))) - -(def-function ("db_close" %db-close) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-close (db flags)) - -(def-function ("db_open" %db-open) - ((db :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (type DBTYPE) - (flags :unsigned-int) - (mode :int)) - :returning :int) - -(wrap-errno db-open (db transaction file database type flags mode) - :flags (auto-commit create dirty-read excl nommap - rdonly thread truncate) - :keys ((transaction *current-transaction*) - (file +NULL-CHAR+) - (database +NULL-CHAR+) - (type DB-UNKNOWN) - (mode #o640)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_remove" %db-remove) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-remove (db file database flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database)) - -(def-function ("db_rename" %db-rename) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-rename (db file database newname flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database newname)) - -(def-function ("db_sync" %db-sync) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-sync (db flags)) - -(def-function ("db_truncate" %db-truncate) - ((db :pointer-void) - (txn :pointer-void) - (count :unsigned-int :out) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-truncate (db transaction flags) :flags (auto-commit) - :keys ((transaction *current-transaction*)) :outs 2 - :transaction transaction) - -;; Accessors - -(def-function ("db_get_raw" %db-get-key-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(defun db-get-key-buffered (db key-buffer key-length &key - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key-buffer) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-key-buffered db transaction key-buffer key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-key-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-key-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length))))) - -(def-function ("db_get_raw" %db-get-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(defun db-get-buffered (db key &key - (key-length (length key)) - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (with-cstring (k key) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-buffered db transaction k key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(defun db-get (db key &key (key-length (length key)) - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (with-cstring (k key) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-buffered db transaction k key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get - (convert-from-foreign-string *get-buffer* - :length result-length - :null-terminated-p nil))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get nil)) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(def-function ("db_put_raw" %db-put-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (datum array-or-pointer-char) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put-buffered (db transaction key key-length - datum datum-length flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_put_raw" %db-put) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (datum :cstring) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put (db transaction key key-length datum datum-length flags) - :flags (auto-commit) - :keys ((key-length (length key)) - (datum-length (length datum)) - (transaction *current-transaction*)) - :cstrings (key datum) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_del" %db-delete-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete-buffered (db key key-length &key auto-commit - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type array-or-pointer-char key) - (type fixnum key-length) (type boolean auto-commit)) - (let ((errno (%db-delete-buffered db transaction - key key-length - (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) t) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))))) - -(def-function ("db_del" %db-delete) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete (db key &key auto-commit (key-length (length key)) - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type string key) - (type fixnum key-length) (type boolean auto-commit)) - (with-cstrings ((key key)) - (let ((errno - (%db-delete db transaction key - key-length (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) nil) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno)))))) - -;; Transactions - -(def-function ("db_txn_begin" %db-txn-begin) - ((env :pointer-void) - (parent :pointer-void) - (flags :unsigned-int) - (errno (* :int))) - :returning :pointer-void) - -(defun db-transaction-begin (env &key (parent *current-transaction*) - dirty-read txn-nosync txn-nowait - txn-sync) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void env parent) - (type boolean dirty-read txn-nosync txn-nowait - txn-sync) - (type pointer-int *errno-buffer*)) - (let* ((txn - (%db-txn-begin env parent - (flags :dirty-read dirty-read - :txn-nosync txn-nosync - :txn-nowait txn-nowait - :txn-sync txn-sync) - *errno-buffer*)) - (errno (deref-array *errno-buffer* '(:array :int) 0))) - (declare (type pointer-void txn) - (type fixnum errno)) - (if (= errno 0) - txn - (error 'db-error :errno errno)))) - -(def-function ("db_txn_abort" %db-txn-abort) - ((txn :pointer-void)) - :returning :int) - -(wrap-errno (db-transaction-abort %db-txn-abort) (transaction) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction))) - -(def-function ("db_txn_commit" %db-txn-commit) - ((txn :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) - :keys ((transaction *current-transaction*)) - :flags (txn-nosync txn-sync) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction) - (type boolean txn-nosync txn-sync))) - -(defmacro with-transaction ((&key transaction environment - (parent '*current-transaction*) - (retries 100) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - (let ((txn (if transaction transaction (gensym))) - (count (gensym)) - (result (gensym)) - (success (gensym))) - `(loop for ,count fixnum from 1 to ,retries - for ,txn of-type pointer-void = - (db-transaction-begin ,environment - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - for ,success of-type boolean = nil - for ,result = - (let ((*current-transaction* ,txn)) - (catch ,txn - (unwind-protect - (prog1 (progn ,@body) - (setq ,success t) - (db-transaction-commit :transaction ,txn - :txn-nosync ,txn-nosync - :txn-sync ,txn-sync)) - (unless ,success - (db-transaction-abort :transaction ,txn))))) - do - (unless (and (eq ,result ,txn) (not ,success)) - (return ,result)) - finally (error "Too many retries")))) - -;; this is code for a non-consing with-transaction. which -;; doesn't work in the (globally t) case (e.g. setting -;; *current-transaction*.) - -; #+cmu -; `(alien:with-alien ((,txn (* t) -; (%db-txn-begin -; ,environment ,parent -; (flags :dirty-read ,dirty-read -; :txn-nosync ,txn-nosync -; :txn-nowait ,txn-nowait -; :txn-sync ,txn-sync) -; *errno-buffer*))) -; (let ((,success nil) -; ,@(if globally `((*current-transaction* ,txn)) (values))) -; (declare (type pointer-void *current-transaction*) -; (dynamic-extent *current-transaction*)) -; (unwind-protect -; (prog1 (progn ,@body) -; (setq ,success t) -; (%db-txn-commit ,txn -; (flags :txn-nosync ,txn-nosync -; :txn-sync ,txn-sync))) -; (unless ,success (%db-txn-abort ,txn))))))) - - -;; Locks and timeouts - - -(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT - :PUT :PUT-ALL :PUT-OBJ :PUT-READ - :TIMEOUT :TRADE :UPGRADE-WRITE)) - -(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT - :IWRITE :IREAD :IWR :DIRTY :WWRITE)) - -(def-struct DB-LOCK - (off :unsigned-int) - (ndx :unsigned-int) - (gen :unsigned-int) - (mode DB-LOCKMODE)) - -#+openmcl -(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) - -(def-struct DB-LOCKREQ - (op DB-LOCKOP) - (mode DB-LOCKMODE) - (timeout :unsigned-int) - (obj (:array :char)) - (lock (* DB-LOCK))) - -#+openmcl -(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) - -(def-function ("db_txn_id" %db-transaction-id) - ((transaction :pointer-void)) - :returning :unsigned-int) - -(defun db-transaction-id (&optional (transaction *current-transaction*)) - (%db-transaction-id transaction)) - -(def-function ("db_env_lock_id" %db-env-lock-id) - ((env :pointer-void) - (id :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-lock-id (env) :outs 2) - - -(def-function ("db_env_lock_id_free" %db-env-lock-id-free) - ((env :pointer-void) - (id :unsigned-int)) - :returning :int) - -(wrap-errno db-env-lock-id-free (env id)) - -(def-function ("db_env_lock_get" %db-env-lock-get) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (object array-or-pointer-char) - (object-length :unsigned-int) - (lock-mode DB-LOCKMODE) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-get (env locker flags object object-length - lock-mode lock) - :flags (lock-nowait)) - -(def-function ("db_env_lock_put" %db-env-lock-put) - ((env :pointer-void) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-put (env lock)) - -(defmacro with-lock ((env locker object object-length - &key (lock-mode DB-LOCKMODE#WRITE) - lock-nowait) - &body body) - (let ((lock (gensym)) - (locked (gensym))) - `(with-foreign-object (,lock 'DB-LOCK) - (let ((,locked nil)) - (unwind-protect - (progn - (db-env-lock-get ,env ,locker ,object ,object-length ,lock-mode - ,lock :lock-nowait ,lock-nowait) - (setq ,locked T) - ,@body) - (when ,locked (db-env-lock-put ,env ,lock))))))) - -(def-function ("db_env_lock_vec" %db-env-lock-vec) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (list (:array DB-LOCKREQ)) - (nlist :int) - (elistp (* (* DB-LOCKREQ)))) - :returning :int) - -(def-function ("db_env_set_timeout" %db-env-set-timeout) - ((env :pointer-void) - (timeout :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-set-timeout (env timeout flags) - :flags (set-lock-timeout set-transaction-timeout)) - -(def-function ("db_env_get_timeout" %db-env-get-timeout) - ((env :pointer-void) - (timeout :unsigned-int :out) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-get-timeout (env flags) :outs 2 - :flags (set-lock-timeout set-transaction-timeout)) - -(defconstant DB_LOCK_DEFAULT 1) -(defconstant DB_LOCK_EXPIRE 2) -(defconstant DB_LOCK_MAXLOCKS 3) -(defconstant DB_LOCK_MINLOCKS 4) -(defconstant DB_LOCK_MINWRITE 5) -(defconstant DB_LOCK_OLDEST 6) -(defconstant DB_LOCK_RANDOM 7) -(defconstant DB_LOCK_YOUNGEST 8) - -(def-function ("db_env_set_lk_detect" %db-env-set-lock-detect) - ((env :pointer-void) - (detect :unsigned-int)) - :returning :int) - -(wrap-errno db-env-set-lock-detect (env detect)) - -(def-function ("db_env_get_lk_detect" %db-env-get-lock-detect) - ((env :pointer-void) - (detect :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-get-lock-detect (env) :outs 2) - -(def-function ("db_env_lock_detect" %db-env-lock-detect) - ((env :pointer-void) - (flags :unsigned-int) - (atype :unsigned-int) - (aborted :int :out)) - :returning :int) - -(wrap-errno db-env-lock-detect (env flags atype) :outs 2) - -;; Poor man's counters - -(def-function ("next_counter" %next-counter) - ((env :pointer-void) - (db :pointer-void) - (parent :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (lockid array-or-pointer-char) - (lockid-length :unsigned-int)) - :returning :int) -(defun next-counter (env db parent key key-length lockid lockid-length) - (let ((ret (%next-counter env db parent key key-length lockid lockid-length))) - (if (< ret 0) - (error 'db-error :errno ret) - ret))) - -;; Misc - -(defun flags (&key - auto-commit - joinenv - init-cdb - init-lock - init-log - init-mpool - init-rep - init-txn - recover - recover-fatal - lockdown - private - system-mem - thread - force - get-both - dirty-read - create - excl - nommap - rdonly - truncate - txn-nosync - txn-nowait - txn-sync - set-lock-timeout - set-transaction-timeout - lock-nowait) - (let ((flags 0)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type (unsigned-byte 32) flags) - (type boolean auto-commit joinenv init-cdb init-lock - init-log init-mpool init-rep init-txn - recover recover-fatal lockdown private - system-mem thread force get-both - dirty-read create excl nommap rdonly - truncate txn-nosync txn-nowait - set-lock-timeout set-transaction-timeout)) - (when auto-commit (setq flags (logior flags DB_AUTO_COMMIT))) - (when joinenv (setq flags (logior flags DB_JOINENV))) - (when init-cdb (setq flags (logior flags DB_INIT_CDB))) - (when init-lock (setq flags (logior flags DB_INIT_LOCK))) - (when init-log (setq flags (logior flags DB_INIT_LOG))) - (when init-mpool (setq flags (logior flags DB_INIT_MPOOL))) - (when init-rep (setq flags (logior flags DB_INIT_REP))) - (when init-txn (setq flags (logior flags DB_INIT_TXN))) - (when recover (setq flags (logior flags DB_RECOVER))) - (when recover-fatal (setq flags (logior flags DB_RECOVER_FATAL))) - (when lockdown (setq flags (logior flags DB_LOCKDOWN))) - (when private (setq flags (logior flags DB_PRIVATE))) - (when system-mem (setq flags (logior flags DB_SYSTEM_MEM))) - (when thread (setq flags (logior flags DB_THREAD))) - (when force (setq flags (logior flags DB_FORCE))) - (when get-both (setq flags (logior flags DB_GET_BOTH))) - (when dirty-read (setq flags (logior flags DB_DIRTY_READ))) - (when create (setq flags (logior flags DB_CREATE))) - (when excl (setq flags (logior flags DB_EXCL))) - (when nommap (setq flags (logior flags DB_NOMMAP))) - (when rdonly (setq flags (logior flags DB_RDONLY))) - (when truncate (setq flags (logior flags DB_TRUNCATE))) - (when txn-nosync (setq flags (logior flags DB_TXN_NOSYNC))) - (when txn-nowait (setq flags (logior flags DB_TXN_NOWAIT))) - (when txn-sync (setq flags (logior flags DB_TXN_SYNC))) - (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT))) - (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT))) - (when lock-nowait (setq flags (logior flags DB_LOCK_NOWAIT))) - flags)) - -;; Errors - -(def-function ("db_strerr" %db-strerror) - ((error :int)) - :returning :cstring) - -(defun db-strerror (errno) - (convert-from-cstring (%db-strerror errno))) - -(define-condition db-error (error) - ((errno :type fixnum :initarg :errno :reader db-error-errno)) - (:report - (lambda (condition stream) - (declare (type db-error condition) (type stream stream)) - (format stream "Berkeley DB error: ~A" - (db-strerror (db-error-errno condition))))))

1 0

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25896/src Modified Files: serializer.lisp Log Message: doc-strings buffer-streamified sanified type tags Date: Thu Sep 16 06:20:42 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.8 elephant/src/serializer.lisp:1.9 --- elephant/src/serializer.lisp:1.8 Sat Sep 4 10:59:40 2004 +++ elephant/src/serializer.lisp Thu Sep 16 06:20:41 2004 @@ -51,30 +51,46 @@ ;; Constants -(defconstant +fixnum+ (char-code #\f)) -(defconstant +nil+ (char-code #\N)) -(defconstant +symbol+ (char-code #\S)) -(defconstant +string+ (char-code #\s)) -(defconstant +persistent+ (char-code #\P)) -(defconstant +single-float+ (char-code #\F)) -(defconstant +double-float+ (char-code #\D)) -(defconstant +char+ (char-code #\c)) -(defconstant +pathname+ (char-code #\p)) -(defconstant +positive-bignum+ (char-code #\B)) -(defconstant +negative-bignum+ (char-code #\b)) -(defconstant +rational+ (char-code #\r)) -(defconstant +cons+ (char-code #\C)) -(defconstant +hash-table+ (char-code #\H)) -(defconstant +object+ (char-code #\O)) +(defconstant +fixnum+ 1) +(defconstant +char+ 2) +(defconstant +single-float+ 3) +(defconstant +double-float+ 4) +(defconstant +negative-bignum+ 5) +(defconstant +positive-bignum+ 6) +(defconstant +rational+ 7) + +(defconstant +nil+ 8) + +;; 8-bit +#-(or lispworks (and allegro ics)) +(defconstant +symbol+ 9) +#-(or lispworks (and allegro ics)) +(defconstant +string+ 10) +#-(or lispworks (and allegro ics)) +(defconstant +pathname+ 11) + +;; 16-bit +#+(or lispworks (and allegro ics)) +(defconstant +symbol+ 12) +#+(or lispworks (and allegro ics)) +(defconstant +string+ 13) +#+(or lispworks (and allegro ics)) +(defconstant +pathname+ 14) + +(defconstant +persistent+ 15) +(defconstant +cons+ 16) +(defconstant +hash-table+ 17) +(defconstant +object+ 18) +(defconstant +array+ 19) -(defconstant +array+ (char-code #\A)) - -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defconstant +fill-pointer-p+ #x40) +(defconstant +adjustable-p+ #x80) (defun serialize (frob bs) - (declare (optimize (speed 3) (safety 0))) + "Serialize a lisp value into a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clrhash *circularity-hash*) (labels @@ -207,7 +223,7 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - (finish-buffer bs))) + bs)) (defun slots-and-values (o) (declare (optimize (speed 3) (safety 0))) @@ -222,14 +238,10 @@ (push slot-name ret)) finally (return ret))) -(defun deserialize (buf) +(defun deserialize (buf-str) + "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) - (type (or null array-or-pointer-char) buf)) - (unless buf (return-from deserialize nil)) - (setf (buffer-stream-buffer *in-buf*) buf) - (setf (buffer-stream-position *in-buf*) 0) - (setq *lisp-obj-id* 0) - (clrhash *circularity-hash*) + (type (or null buffer-stream) buf-str)) (labels ((%deserialize (bs) (declare (optimize (speed 3) (safety 0)) @@ -325,7 +337,12 @@ (setf (row-major-aref a i) (%deserialize bs))) a)))) (t (error "deserialize fubar!")))))) - (%deserialize *in-buf*))) + (etypecase buf-str + (null (return-from deserialize nil)) + (buffer-stream + (setq *lisp-obj-id* 0) + (clrhash *circularity-hash*) + (%deserialize buf-str))))) (defun deserialize-bignum (bs length positive) (declare (optimize (speed 3) (safety 0)) @@ -387,9 +404,9 @@ (defun int-byte-spec (position) (declare (optimize (speed 3) (safety 0)) (type (unsigned-byte 24) position)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) - #-(or cmu scl sbcl allegro) + #-(or cmu sbcl allegro) (byte 32 (* 32 position)) )

1 0

[elephant-cvs] CVS update: elephant/src/berkeley-db.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25863/src Added Files: berkeley-db.lisp Log Message: split from sleepycat.lisp doc-strings buffer-streamified Date: Thu Sep 16 06:19:57 2004 Author: blee

1 0