elephant-cvs January 2007

elephant-cvs@common-lisp.net

2 participants
37 discussions

[elephant-cvs] CVS elephant/tests
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv5278/tests Modified Files: testsorter.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/tests/testsorter.lisp 2006/11/11 18:41:11 1.3 +++ /project/elephant/cvsroot/elephant/tests/testsorter.lisp 2007/01/20 22:12:18 1.4 @@ -55,14 +55,15 @@ :returning :double) (defun read-num (num) - (declare (optimize (speed 3)) + (declare #-elephant-without-optimizations (optimize (speed 3)) (type integer num)) (with-buffer-streams (nb) (serialize num nb) (%read-num (buffer-stream-buffer nb)))) (defun num-test (num) - (declare (optimize (speed 3)) (type integer num)) + (declare #-elephant-without-optimizations (optimize (speed 3)) + (type integer num)) (loop with i of-type double-float = 0.0d0 for j fixnum from 0 below (ceiling (/ (integer-length num) 32)) for bs = (byte 32 (* j 32)) @@ -73,7 +74,7 @@ (defun find-bad-num (bot top) - (declare (optimize (speed 3)) + (declare #-elephant-without-optimizations (optimize (speed 3)) (type integer bot top)) (cond ((= bot top) bot) ((= bot (- top 1)) @@ -85,7 +86,7 @@ (find-bad-num bot middle)))))) (defun rfind-bad-num (bot top) - (declare (optimize (speed 3)) + (declare #-elephant-without-optimizations (optimize (speed 3)) (type integer bot top)) (cond ((= bot top) bot) ((= bot (- top 1))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv5278/src/elephant Modified Files: controller.lisp cross-platform.lisp package.lisp serializer.lisp serializer2.lisp variables.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/19 21:03:30 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/20 22:12:17 1.19 @@ -26,7 +26,6 @@ (defparameter *elephant-backends* '((:bdb (:ele-bdb)) (:clsql (:ele-clsql)) -;; (:acache (:ele-acache)) ) "Entries have the form of (backend-type asdf-depends-list") @@ -102,53 +101,6 @@ ;; ;; ================================================ -;; -;; Callback hooks for persistent variables -;; -;; NOTE: Design sketch; not sure I'll include this... - -;;(defvar *variable-hooks* nil -;; "An alist (specs -> varlist) where varlist is tuple of -;; lisp name, store name (auto) and policy") - -;;(defun add-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (push name (assoc spec *variable-hooks* :test #'equal)) -;; (push (cons spec (list name)) *variable-hooks*))) - -;;(defun remove-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (setf (assoc spec *variable-hooks* :test #'equal) -;; (remove name (assoc spec *variable-hooks* :test #'equal))) -;; (error "No hooks declared on ~A" spec))) - -;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) -;; `(progn -;; (defvar ,name ,initial-value ,documentation) -;; (add-hook ,name ,spec) -;; ,(case policy -;; (:wrap-mutators -;; `(progn -;; ,(loop for accessor in accessors do -;; (let ((gf (ensure-generic-function -;; `(defmethod ,accessor :after ( - -;; (defpvar *agencies* (:wrap-mutators -;; 'add-agent -;; 'remove-agent -;; 'clear-agents) -;; nil -;; "test") - -;; (defmethod add-agent (agent) -;; (push agent *agencies*)) - -;; (defmethod remove-agent (agent) -;; (setf *agencies* (remove agent *agencies*))) - -;; (defmethod clear-agents (agent) -;; (setf *agencies* nil)) - ;; ;; Open a Store @@ -157,10 +109,11 @@ (defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) + ;; setup system config parameters (if necessary) + ;; GF iface to overload by backend (setq *store-controller* (get-controller spec)) (initialize-serializer *store-controller*) - (ensure-properties - (apply #'open-controller *store-controller* args))) + (apply #'open-controller *store-controller* args)) (defun close-store (&optional sc) "Conveniently close the store controller." @@ -205,6 +158,7 @@ ;; Symbol ID caches (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000)) (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000)) + (fast-symbols :accessor controller-fast-symbols-p :initform nil) ) (:documentation "Class of objects responsible for the book-keeping of holding DB @@ -213,24 +167,24 @@ (defun initialize-serializer (sc) "Establish serializer version on controller startup" - (cond ((equal (controller-version sc) '(0 6 1)) - (setf (controller-serializer-version sc) 2) - (setf (controller-serialize sc) 'elephant-serializer2::serialize) - (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)) - ((prior-version-p (controller-version sc) '(0 6 0)) + (cond ((prior-version-p (controller-version sc) '(0 6 0)) (setf (controller-serializer-version sc) 1) (setf (controller-serialize sc) 'elephant-serializer1::serialize) (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) - (t (error "Unsupported Elephant database version")))) + (t + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)))) ;; ;; VERSIONING ;; -(defvar *restricted-properties* '(:version) - "Properties that are not user manipulable") - -(defmethod controller-version ((sc store-controller)) +(defmethod database-version ((sc store-controller)) + (:documentation "A version determination for a given store + controller that is independant of the serializer as the + serializer is dispatched based on the code version which is a + list of the form '(0 6 0)")) (let ((version (controller-version-cached sc))) (if version version (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) @@ -252,82 +206,6 @@ (prior-version-p (cdr v1) (cdr v2))) (t (error "Version problem!")))) -(defmethod ensure-properties ((sc store-controller)) - "Not sure this test is right (empty root)" - (let ((props (controller-properties sc)) - (empty? (and (empty-btree-p (controller-root sc)) - (empty-btree-p (controller-class-root sc))))) - ;; marked - continue - (unless (assoc :version props) - (if empty? - ;; empty so new database - mark with current code version - (setf (get-value *elephant-properties-label* (controller-root sc)) - (acons :version *elephant-code-version* props)) - ;; has stuff in it but not marked - mark as prior - (setf (get-value *elephant-properties-label* (controller-root sc)) - (acons :version *elephant-unmarked-code-version* props))))) - sc) - - -;; -;; Upgrade paths -;; - -(defmethod up-to-date-p ((sc store-controller)) - (equal (controller-version sc) *elephant-code-version*)) - -(defmethod upgrade ((sc store-controller) target-spec) - (unless (upgradable-p sc) - (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" - (controller-spec sc) - (controller-version sc) - *elephant-code-version* - *elephant-upgrade-table*)) - (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your - data does not require any unsupported features") - (let ((source sc) - (target (open-store target-spec))) - (migrate target source) - (close-store target))) - -(defparameter *elephant-upgrade-table* - '( ((0 6 0) (0 5 0)) - ((0 6 1) (0 6 0)) - )) - -(defmethod upgradable-p ((sc store-controller)) - "Determine if this store can be brought up to date using the upgrade function" - (unwind-protect - (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) - (ver (controller-version sc))) - (when (member ver (rest row) :test #'equal)) t) - nil)) - - -;; -;; PROPERTIES -;; - -(defmethod controller-properties ((sc store-controller)) - (get-from-root *elephant-properties-label* :store-controller sc)) - -(defmethod set-ele-property (property value &key (sc *store-controller*)) - (assert (and (symbolp property) (not (member property *restricted-properties*)))) - (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) - (setf (get-value *elephant-properties-label* (controller-root sc)) - (if (assoc property props) - (progn (setf (cdr (assoc property props)) value) - props) - (acons property value props))))) - -(defmethod get-ele-property (property &key (sc *store-controller*)) - (assert (symbolp property)) - (let ((entry (assoc property - (get-from-root *elephant-properties-label* - :store-controller sc)))) - (when entry - (cdr entry)))) - ;; ;; OBJECT CACHE ;; @@ -392,12 +270,6 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) -(defgeneric database-version ((sc store-controller)) - (:documentation "A version determination for a given store - controller that is independant of the serializer as the - serializer is dispatched based on the code version which is a - list of the form '(0 6 0)")) - (defgeneric connection-is-indeed-open (controller) (:documentation "Validate the controller and the db that it is connected to") (:method ((controller t)) t)) @@ -411,6 +283,7 @@ "Tell the backend to reclaim any storage caused by key deletion, if possible. This should default to return space to the filesystem rather than just to the free list.")) + ;; ;; Object Root Operations ;; @@ -420,7 +293,7 @@ retrieve it in a later session. N.B. this means it (and everything it points to) won't get gc'd." (declare (type store-controller store-controller)) - (assert (not (eq key *elephant-properties-label*))) +;; (assert (not (eq key *elephant-properties-label*))) (setf (get-value key (controller-root store-controller)) value)) (defun get-from-root (key &key (store-controller *store-controller*)) @@ -453,6 +326,118 @@ (remhash (controller-spec sc) *dbconnection-spec*)) ;; +;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1) +;; + +(defvar *restricted-properties* '() + "Properties that are not user manipulable") + +(defmethod controller-properties ((sc store-controller)) + (get-from-root *elephant-properties-label* :store-controller sc)) + +(defmethod set-ele-property (property value &key (sc *store-controller*)) + (assert (and (symbolp property) (not (member property *restricted-properties*)))) + (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) + (setf (get-value *elephant-properties-label* (controller-root sc)) + (if (assoc property props) + (progn (setf (cdr (assoc property props)) value) + props) + (acons property value props))))) + +(defmethod get-ele-property (property &key (sc *store-controller*)) + (assert (symbolp property)) + (let ((entry (assoc property + (get-from-root *elephant-properties-label* + :store-controller sc)))) + (when entry + (cdr entry)))) + + +;; +;; Upgrade paths +;; + +(defmethod up-to-date-p ((sc store-controller)) + (equal (controller-version sc) *elephant-code-version*)) + +(defmethod upgrade ((sc store-controller) target-spec) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (controller-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your + data does not require any unsupported features") + (let ((source sc) + (target (open-store target-spec))) + (migrate target source) + (close-store target))) + +(defparameter *elephant-upgrade-table* + '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) + )) + +(defmethod upgradable-p ((sc store-controller)) + "Determine if this store can be brought up to date using the upgrade function" + (unwind-protect + (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) + (ver (controller-version sc))) + (when (member ver (rest row) :test #'equal)) t) + nil)) + + +;; +;; Callback hooks for persistent variables +;; + +;; NOTE: Design sketch; not sure I'll promote this... + +;;(defvar *variable-hooks* nil +;; "An alist (specs -> varlist) where varlist is tuple of +;; lisp name, store name (auto) and policy") + +;;(defun add-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (push name (assoc spec *variable-hooks* :test #'equal)) +;; (push (cons spec (list name)) *variable-hooks*))) + +;;(defun remove-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (setf (assoc spec *variable-hooks* :test #'equal) +;; (remove name (assoc spec *variable-hooks* :test #'equal))) +;; (error "No hooks declared on ~A" spec))) + +;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) +;; `(progn +;; (defvar ,name ,initial-value ,documentation) +;; (add-hook ,name ,spec) +;; ,(case policy +;; (:wrap-mutators +;; `(progn +;; ,(loop for accessor in accessors do +;; (let ((gf (ensure-generic-function +;; `(defmethod ,accessor :after ( + +;; (defpvar *agencies* (:wrap-mutators +;; 'add-agent +;; 'remove-agent +;; 'clear-agents) +;; nil +;; "test") + +;; (defmethod add-agent (agent) +;; (push agent *agencies*)) + +;; (defmethod remove-agent (agent) +;; (setf *agencies* (remove agent *agencies*))) + +;; (defmethod clear-agents (agent) +;; (setf *agencies* nil)) + + +;; ;; Support for serialization efficiency ;; @@ -465,6 +450,7 @@ (:documentation "Return a symbol for the ID. This should always succeed. The database should not use the existing serializer to perform this function; but memutils and unicode are available")) + ;; ;; Low-level support for metaclass protocol ;; --- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/20 22:12:18 1.2 @@ -17,7 +17,7 @@ (in-package :elephant) ;; This is a quick portability hack to avoid external dependencies, if we get -;; to many of these do we need to import a standard library? do we need to import 'port' or some +;; too many of these do we need to import a standard library? do we need to import 'port' or some ;; other thread layer to the elephant dependency list? (defmacro ele-without-interrupts (&body body) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/19 21:03:30 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/20 22:12:18 1.6 @@ -26,7 +26,7 @@ "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:*elephant-lib-path* #:*elephant-code-version* + #:*elephant-lib-path* #:*elephant-code-version* #:*fast-symbols* #:store-controller #:controller-root #:controller-class-root #:controller-version #:controller-serializer-version --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/12/16 19:35:10 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/20 22:12:18 1.16 @@ -26,6 +26,9 @@ current Elephant version" (funcall (symbol-function (controller-deserialize sc)) bs sc)) +;;(defun serializer-feature (sc) +;; ( + ;; ;; SQL encoding support ;; --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/20 22:12:18 1.2 @@ -460,27 +460,17 @@ ;; Symbol cache ;; -(defun deserialize-symbol-id (id sc) - "Deserialize a symbol ID by finding it in the cache" - (declare (type fixnum id)) - (let ((symbol (gethash id (controller-symbol-cache sc)))) - (if symbol symbol - (let ((symbol (lookup-persistent-symbol sc id))) - (if symbol - (progn - (setf (gethash id (controller-symbol-cache sc)) symbol) - (setf (gethash symbol (controller-symbol-id-cache sc)) id) - symbol) - (error "Symbol lookup foobar! ID referred to does not exist in database")))))) - (defun serialize-symbol (symbol bs sc) "Serialize a symbol by recording its ID" (declare (type buffer-stream bs) - (type symbol symbol)) - (let ((id (lookup-id symbol sc))) - (declare (type fixnum id)) - (buffer-write-byte +symbol-id+ bs) - (buffer-write-int id bs))) + (type symbol symbol) + (type store-controller sc)) + (if *fast-symbols* + (let ((id (lookup-id symbol sc))) + (declare (type fixnum id)) + (buffer-write-byte +symbol-id+ bs) + (buffer-write-int id bs)) + (serialize-symbol-complete symbol bs))) (defun lookup-id (symbol sc) "Find an id for a symbol or create a new one" @@ -509,6 +499,19 @@ (serialize-string (package-name package) bs) (buffer-write-byte +nil+ bs))))) +(defun deserialize-symbol-id (id sc) + "Deserialize a symbol ID by finding it in the cache" + (declare (type fixnum id)) + (let ((symbol (gethash id (controller-symbol-cache sc)))) + (if symbol symbol + (let ((symbol (lookup-persistent-symbol sc id))) + (if symbol + (progn + (setf (gethash id (controller-symbol-cache sc)) symbol) + (setf (gethash symbol (controller-symbol-id-cache sc)) id) + symbol) + (error "Symbol lookup foobar! ID referred to does not exist in database")))))) + ;; ;; Array type tags --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/12/16 19:35:10 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/20 22:12:18 1.7 @@ -43,6 +43,8 @@ Users attempting to directly write this variable will run into an error") +(defvar *fast-symbols* nil) + ;;;;;;;;;;;;;;;;; ;;;; Serializer optimization parameters

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv5278/src/memutil Modified Files: memutil.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/12/16 19:35:10 1.13 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/01/20 22:12:18 1.14 @@ -84,7 +84,7 @@ (eval-when (compile) (declaim - (optimize (speed 3) (safety 1) (space 0) (debug 0)) + #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (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-str-to-buf copy-bufs

1 0

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

20 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv5278 Modified Files: TODO config.sexp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/TODO 2007/01/19 21:03:29 1.32 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/20 22:12:17 1.33 @@ -114,16 +114,16 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.6.2 - Advanded work, low-hanging fruit (Fall '06) +0.6.2 - Advanded work, low-hanging fruit (Summer '07) -------------------------------------------------- + - Persistent variables (abstraction that allows compound lisp objects at the cost of + full serialization after each write that indirects through the API). Can this be done + with clean semantics or should we punt it? - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - Evaluate porting elephant to closer-to-MOP to make it easier to support additional lisps and to seriously clean up metaclasses.lisp and classes.lisp protocols - A wrapper around migration that emulates a stop-and-copy GC - -0.6.3 - Documentation & Tools (Winter '06) --------------------------------------------------- - Tutorial example rethink: update the blog tutorial using indexed objects to create different views as well as integrating something like logging for admin or version control purposes. @@ -135,6 +135,7 @@ 0.7.0: Fast In-Memory Database (Not backwards compatible) -------------------------------------------------- + - Full support for DCM or integration of DCM functionality - Integrate prevalence-like in-memory database system for single image, multiple-thread operation - Fast serializer port w/ upgrade strategy and prevalence like storage solution - Further improve SQL 64-bit serialization performance (if possible) @@ -170,16 +171,18 @@ 0.9.0 - Supporting Tools Release -------------------------------------------------- - - Document DCM? - - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) - - Simple object query language (Ian - orthogonal, on main branch) - - Repository browser (Ian - orthogonal, on main branch) - (a simple REPL tool to see what classes are in a repository and - what state they're in...useful for long-lived repositories) - - - - + - Support a simple object query language over the database + - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) + - Repository browser - a simple REPL tool like the Slime inspector + to see what classes are in a repository and what state they're in...useful + for long-lived repositories or if you've forgotten a variable name + +1.0 - Production release (1st fully supported version since 0.7.1) +-------------------------------------------------- + - Finalize supported platforms (LispWorks? OpenMCL?) + - Significant work on test cases & testing framework + - Final pass of performance enhancements + - Invite community review and testing ======================================================== ======================================================== --- /project/elephant/cvsroot/elephant/config.sexp 2006/12/16 19:35:09 1.2 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/01/20 22:12:17 1.3 @@ -1,8 +1,9 @@ -((:berkeley-db-root . "/usr/local/BerkeleyDB.4.4/") +((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.4/") + (:berkeley-db-lib-dir . "/opt/local/lib/db44/") (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib") (:pthread-lib . nil) (:clsql-lib . nil) - (:fast-symbols . t)) + (:fast-symbols . nil)) ;; Typical pthread settings are: /lib/tls/libpthread.so.0 ;; nil means that the library in question is not loaded

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv5278/src/db-bdb Modified Files: berkeley-db.lisp libberkeley-db.c libberkeley-db.def Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/19 21:03:29 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/20 22:12:17 1.3 @@ -466,7 +466,17 @@ (wrap-errno db-env-get-flags (env) :outs 2 :documentation "Get flags of an environment.") - + +(def-function ("db_env_txn_checkpoint" %db-env-txn-checkpoint) + ((env :pointer-void) + (kbyte :unsigned-int) + (min :unsigned-int) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-env-txn-checkpoint (env kbyte min flags) + :flags (force) + :documentation "Make a checkpoint.") ;; Database --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/19 21:03:29 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/20 22:12:17 1.5 @@ -210,6 +210,11 @@ return dbenv->get_flags(dbenv, flagsp); } +int db_env_txn_checkpoint(DB_ENV *dbenv, u_int32_t kbyte, u_int32_t min, + u_int32_t flags) { + return dbenv->txn_checkpoint(dbenv, kbyte, min, flags); +} + /* Database */ DB *db_cr(DB_ENV *dbenv, u_int32_t flags, int *errno) { --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2006/11/11 18:41:10 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/01/20 22:12:17 1.2 @@ -19,6 +19,7 @@ db_env_remove db_env_set_flags db_env_get_flags + db_env_txn_checkpoint db_cr db_close db_open

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv4428/src/db-bdb Modified Files: bdb-controller.lisp berkeley-db.lisp libberkeley-db.c Added Files: bdb-symbol-tables.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/12/16 19:35:10 1.14 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/19 21:03:29 1.15 @@ -57,16 +57,6 @@ (string t) (otherwise nil)))) -(defmethod controller-version ((sc store-controller)) - (let ((version (controller-version sc))) - (if version version - (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (read stream)) - (with-open-file (stream path :direction :output) - (write *elephant-code-version* :stream stream))))))) - ;; ;; Open/close ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/19 21:03:29 1.2 @@ -1673,10 +1673,11 @@ :returning :int) (def-function ("db_set_lisp_compare" %db-set-lisp-compare) - ((db :pointer-void)) + ((db :pointer-void) + (version :int)) :returning :int) -(wrap-errno db-set-lisp-compare (db) :documentation +(wrap-errno db-set-lisp-compare (db version) :documentation "Sets the Btree comparision function to a hand-cooked function for Elephant to compare lisp values.") @@ -1686,10 +1687,11 @@ :returning :int) (def-function ("db_set_lisp_dup_compare" %db-set-lisp-dup-compare) - ((db :pointer-void)) + ((db :pointer-void) + (version :int)) :returning :int) -(wrap-errno db-set-lisp-dup-compare (db) :documentation +(wrap-errno db-set-lisp-dup-compare (db version) :documentation "Sets the duplicate comparision function to a hand-cooked function for Elephant to compare lisp values.") --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/16 18:02:27 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/19 21:03:29 1.4 @@ -873,8 +873,8 @@ void db_multiple_key_next(void *pointer, DBT *data, unsigned char **key, u_int32_t *ret_key_size, unsigned char **result, u_int32_t *result_size) { - DB_MULTIPLE_KEY_NEXT(pointer, data, - *key, *ret_key_size, + DB_MULTIPLE_KEY_NEXT(pointer, data, + *key, *ret_key_size, *result, *result_size); } --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/19 21:03:30 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/19 21:03:30 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; controller.lisp -- Lisp interface to a Berkeley DB store ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :db-bdb) (defmethod lookup-persistent-symbol-id ((sc bdb-store-controller) symbol) "Look up and create id association for symbol" (with-buffer-streams (keybuf valbuf) (buffer-write-int *symbol-to-id-table-oid* keybuf) (serialize-symbol-complete symbol keybuf) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) (if buf (values (buffer-read-int buf) T) (values (create-persistent-symbol sc symbol keybuf valbuf) t))))) (defun create-persistent-symbol (sc symbol keybuf valbuf) "Takes an symbol->id table + symbol keybuf, allocates an ID and updates the persistent tables." (reset-buffer-stream valbuf) ;; Just to avoid any contamination ;; (with-transaction (:txn-nosync t :dirty-read t) (format t "getting next symid") (let ((id (next-symid sc))) ;; allocate a new unique id ;; Update symbol->id table (format t "Writing sym->id: ~A -> ~A~%" symbol id) (buffer-write-int id valbuf) (format t "Putting id into table location~%") (db-put-buffered (controller-btrees sc) keybuf valbuf :auto-commit *auto-commit*) ;; Write id->symbol table (reset-buffer-stream keybuf) (reset-buffer-stream valbuf) (format t "Writing id->sym: ~A -> ~A~%" id symbol) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) (serialize-symbol-complete symbol valbuf) (db-put-buffered (controller-btrees sc) keybuf valbuf :auto-commit *auto-commit*) id) ;; ) ) (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id) "Lookup the ID associated with a symbol" (with-buffer-streams (keybuf valbuf) (format t "Looking up: ~A~%" id) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) (format t "Get for id: ~A~%" id) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) (format t "Got buf: ~A~%" buf) (if buf (values (deserialize buf sc) T) (error "Invalid ID - no persistent mapping for ID"))))) ;; ;; Stress test ;; (defun stress-test (iters syms) (loop for i fixnum from 0 upto iters do (format t "Iteration ~A~%" i) ;; (with-transaction () ;; (print *current-transaction*) (loop for i fixnum from 0 upto (length syms) do (add-to-root (nth i syms) (nth i syms))))) (defun make-syms (num &aux list) (loop for i fixnum from 0 below num do (let* ((str (format nil "test~A" i)) (sym (intern str))) (push sym list))) (nreverse list))

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv4428/src/db-clsql Modified Files: sql-collections.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/11/11 18:41:11 1.6 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/01/19 21:03:30 1.7 @@ -136,7 +136,7 @@ (tup tuples (cdr tup))) ((= i len) nil) (setf (aref (:sql-crsr-ks cursor) i) - (deserialize-from-base64-string (caar tup) :sc sc))) + (deserialize-from-base64-string (caar tup) sc))) (sort (:sql-crsr-ks cursor) #'my-generic-less-than) (setf (:sql-crsr-ck cursor) 0) (setf (cursor-initialized-p cursor) t) @@ -362,14 +362,14 @@ (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((idx (position key (:sql-crsr-ks cursor)))) + (let ((idx (position key (:sql-crsr-ks cursor) :test #'equal))) (if idx - (progn - (setf (:sql-crsr-ck cursor) idx) - (setf (:dp-nmbr cursor) 0) - (cursor-current-x cursor :returnpk t)) - (cursor-un-init cursor) - ))) + (progn + (setf (:sql-crsr-ck cursor) idx) + (setf (:dp-nmbr cursor) 0) + (cursor-current-x cursor :returnpk t)) + (cursor-un-init cursor) + ))) (defun array-index-if (p a) (do ((i 0 (1+ i)))

1 0

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

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4428/src/elephant Modified Files: controller.lisp package.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/12/16 19:35:10 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/19 21:03:30 1.18 @@ -198,7 +198,7 @@ (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") ;; Upgradable serializer strategy - (version :accessor controller-version :initform nil) + (version :accessor controller-version-cached :initform nil) (serializer-version :accessor controller-serializer-version :initform nil) (serialize :accessor controller-serialize :initform nil) (deserialize :accessor controller-deserialize :initform nil) @@ -230,11 +230,16 @@ (defvar *restricted-properties* '(:version) "Properties that are not user manipulable") -(defgeneric controller-version ((sc store-controller)) - (:documentation "Return the elephant version of this controller - should not - require the serializer to operate as it may be used to determine - the serializer version used to read the DB. This has to be valid - prior to the DB being opened.")) +(defmethod controller-version ((sc store-controller)) + (let ((version (controller-version-cached sc))) + (if version version + (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (setf (controller-version-cached sc) (read stream))) + (with-open-file (stream path :direction :output) + (setf (controller-version-cached sc) + (write *elephant-code-version* :stream stream)))))))) (defun prior-version-p (v1 v2) "Is v1 an equal or earlier version than v2" --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/12/16 19:35:10 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/19 21:03:30 1.5 @@ -29,7 +29,8 @@ #:*elephant-lib-path* #:*elephant-code-version* #:store-controller #:controller-root #:controller-class-root - #:controller-version #:controller-serialize #:controller-deserialize + #:controller-version #:controller-serializer-version + #:controller-serialize #:controller-deserialize #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:get-cached-instance #:flush-instance-cache

1 0

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

19 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4428 Modified Files: TODO ele-bdb.asd elephant.asd Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/TODO 2006/12/16 19:35:09 1.31 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/19 21:03:29 1.32 @@ -14,7 +14,6 @@ - flexible handling of 64-bit fixnums Stability: -- Remove build gensym warnings in sleepycat.lisp - Delete persistent slot values from the slot store with remove-kv to ensure that there's no data left lying around if you define then redefine a class and add back a persistent slot name that you thought was deleted and it gets the old @@ -61,6 +60,8 @@ parameter that determines if this is the default? Performance: +- Allow dump of fast-symbol tables for low-level reconstruction in case of + catastrophic errors - Metering and understanding locking issues. Large transactions seem to use a lot of locks. In general understanding how to use Berkeley DB efficiently seems like a good thing. (From Ben) @@ -85,6 +86,7 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- +January 2006 checkin x Improved optimization options to be more user controlled (Pierre Thierry) x Implement backend support for symbol-table protocol x Speed up symbol storage and reference using symbol id's @@ -94,7 +96,10 @@ x New build interface; all-lisp compilation (sans win32) x Simplify user-specific configuration parameters using config.sexp and my-config.sexp x Make sure to ensure thread safety in buffer-stream allocation! +x Investigated gensym warnings in berkeley-db.lisp (caused by an FFI macro, no harm in it) +x Remove warnings in libberkeley-db.c +Prior to December 2006 x BDB overwrite of values makes DB grow [So far I can only find that it grows on the 2nd write, but not after that...artifact of page allocation or caching of memory pools?] --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/12/16 19:35:09 1.13 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/19 21:03:29 1.14 @@ -31,11 +31,16 @@ (defun get-config-option (option component) (unless *bdb-config* - (with-open-file (config (make-pathname :defaults (asdf:component-pathname - (asdf:component-system component)) - :name "my-config" - :type "sexp")) - (setf *bdb-config* (read config)))) + (let ((filespec (make-pathname :defaults (asdf:component-pathname + +(asdf:component-system component)) + :name "my-config" + :type "sexp"))) + (unless (probe-file filespec) + (error "Missing file. Copy config.sexp in elephant root +directory to my-config.sexp and edit it appropriately.")) + (with-open-file (config filespec) + (setf *bdb-config* (read config))))) (cdr (assoc option *bdb-config*))) ;; --- /project/elephant/cvsroot/elephant/elephant.asd 2006/12/16 19:35:09 1.21 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/01/19 21:03:29 1.22 @@ -130,8 +130,8 @@ (defsystem elephant :name "elephant" :author "Ben Lee <blee(a)common-lisp.net>" - :version "0.6.0" - :maintainer "Ben Lee <blee(a)common-lisp.net>" + :version "0.6.1" + :maintainer "Robert Read <read(a)robertlread.net>" :licence "LLGPL" :description "Object database for Common Lisp" :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro."

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 16 Jan '07

16 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv771 Modified Files: libberkeley-db.c Log Message: Fixed build errors in db-bdb C interface file. This file is not yet complete for serializer2 --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/12/16 19:35:10 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/16 18:02:27 1.3 @@ -67,7 +67,7 @@ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - int int; + int i; memcpy(&i, buf+offset, sizeof(int)); return i; } @@ -79,7 +79,7 @@ } int32_t read_int32(char *buf, int offset) { - int int32_t; + int32_t i; memcpy(&i, buf+offset, sizeof(int32_t)); return i; } @@ -119,7 +119,7 @@ memcpy(buf+offset, &num, sizeof(int)); } -void write_uint(char *buf, unsighed int num, int offset) { +void write_uint(char *buf, unsigned int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); } @@ -277,6 +277,7 @@ double read_num(char *buf); int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2); +int wcs_cmp(const wchar_t *a, int32_t length1, const wchar_t *b, int32_t length2); int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2); int utf16_cmp(const char *s1, int32_t length1, const char *s2, int32_t length2); @@ -316,7 +317,7 @@ } /* Compare types. */ - if + /* ISE: need extra conditional here...forget why, so research it */ difference = at - bt; if (difference) return difference; @@ -335,7 +336,7 @@ case 20: case 21: case 22: - return wcs_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + return wcs_cmp((wchar_t*)ad+9, read_int(ad, 5), (wchar_t*)bd+9, read_int(bd, 5)); default: return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); } @@ -368,33 +369,37 @@ /* Compare numerics. */ if (type_numeric2(at) && type_numeric2(bt)) { - ddifference = read_num2(ad+4) - read_num2(bd+4); + /* ddifference = read_num2(ad+4) - read_num2(bd+4); */ + ddifference = read_num(ad+4) - read_num(bd+4); if (ddifference > 0) return 1; else if (ddifference < 0) return -1; return 0; } /* Compare types. */ - if + /* ISE: need extra conditional here...forget why, so research it */ difference = at - bt; if (difference) return difference; - ;; TODO: compare strings of different sizes? - ;; TODO: compare symbol-ids? + /* TODO: compare strings of different sizes? */ + /* TODO: compare symbol-ids? */ /* Same type! */ switch (at) { - case #x3F: /* nil */ + case 0x3F: /* nil */ return 0; case 9: /* 8-bit string */ + return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + /* ISE: Why did I do this? if( bt == 9 ) return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); else return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)) + */ case 10: /* 16-bit string */ return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); case 11: - return wcs_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + return wcs_cmp((wchar_t*)ad+9, read_int32(ad, 5), (wchar_t*)bd+9, read_int32(bd, 5)); default: return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); } @@ -866,8 +871,8 @@ } void db_multiple_key_next(void *pointer, DBT *data, - char **key, u_int32_t *ret_key_size, - char **result, u_int32_t *result_size) { + unsigned char **key, u_int32_t *ret_key_size, + unsigned char **result, u_int32_t *result_size) { DB_MULTIPLE_KEY_NEXT(pointer, data, *key, *ret_key_size, *result, *result_size); @@ -875,7 +880,7 @@ /* Transactions */ -DB_TXN * db_txn_begin(DB_ENV *env, DB_TXN *parent, +DB_TXN *db_txn_begin(DB_ENV *env, DB_TXN *parent, u_int32_t flags, int *errno) { DB_TXN * p; *errno = env->txn_begin(env, parent, &p, flags);

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 16 Jan '07

16 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4243 Added Files: classes-new.lisp serializer2-locks.lisp serializer3.lisp Log Message: Adding missing files, some of these will go away later but I want to keep a record of my work to date. I really should have put this on a branch, but it got out of control before I realized how much rewiring I was doing! ----------- --- /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp 2007/01/16 00:55:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; classes.lisp -- persistent objects via metaobjects ;;; ;;; Initial version 8/26/2004 by Andrew Blumberg ;;; <ablumberg(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (defvar *debug-si* nil) (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid (sc *store-controller*)) "Sets the OID and home controller" (declare (ignore initargs)) (if (null sc) (error "Initialize instance for type persistent requires valid store controller argument :sc")) (if from-oid (setf (oid instance) from-oid) (setf (oid instance) (next-oid sc))) (setf (:dbcn-spc-pst instance) (controller-spec sc)) (cache-instance sc instance)) (defclass persistent-object (persistent) () (:metaclass persistent-metaclass) (:documentation "Superclass of all user-defined persistent classes. This is automatically inherited if you use the persistent-metaclass metaclass.")) ;; ================================================ ;; METACLASS INITIALIZATION AND CHANGES ;; ================================================ (defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index) "Support the :index class option" (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) (when (and index (subtypep (type-of result) 'persistent-metaclass)) (update-indexed-record result nil :class-indexed t)) result)) (defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index) "Support the :index class option on redefinition" (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) (when index (update-indexed-record result nil :class-indexed t)) result)) (defun remove-index-keyword (list) (cond ((null list) nil) ((eq (car list) :index) (cddr list)) (t (cons (car list) (remove-index-keyword (cdr list)))))) (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) (if (and (not (eq class persistent-object)) not-already-persistent) (apply #'call-next-method class slot-names :direct-superclasses (cons persistent-object direct-superclasses) args) (call-next-method)))) (defmethod finalize-inheritance :around ((instance persistent-metaclass)) "Update the persistent slot records in the metaclass." (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) (cons (persistent-slot-names instance) nil))) (update-indexed-record instance (indexed-slot-names-from-defs instance)))) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) (update-indexed-record instance (indexed-slot-names-from-defs instance)) (if (removed-indexing? instance) (progn (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*)))) (when class-idx (wipe-class-indexing instance class-idx))) (setf (%index-cache instance) nil)) (set-db-synch instance :class)) ;; #+allegro ;; (loop with persistent-slots = (persistent-slots instance) ;; for slot-def in (class-direct-slots instance) ;; when (member (slot-definition-name slot-def) persistent-slots) ;; do (initialize-accessors slot-def instance)) (make-instances-obsolete instance)))) ;; ================================================ ;; PERSISTENT OBJECT MAINTENANCE ;; ================================================ ;; ;; CLASS INSTANCE INITIALIZATION ;; (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used. We also handle writing any indices after the class is fully initialized. Calls the next method for the transient slots." (let* ((class (find-class (class-name (class-of instance)))) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) (unwind-protect (progn ;; initialize the persistent slots ourselves (initialize-persistent-slots class instance persistent-slot-inits initargs) ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs)) (uninhibit-indexing oid)) ;; Inhibit indexing altogether if the object already was defined (ie being created ;; from an oid) as it should be indexed already. This hack avoids a deadlock ;; situation where we write the class or index page that we are currently reading ;; via a cursor without going through the cursor abstraction. There has to be a ;; better way to do this. (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index class))) (when class-index (setf (get-value oid class-index) instance)))) )))) (defun initialize-persistent-slots (class instance persistent-slot-inits initargs) (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs with slot-initargs = (slot-definition-initargs slot-def) when (member initarg slot-initargs :test #'eq) do (setf (slot-value-using-class class instance slot-def) (getf initargs initarg)) (return t)))) (with-transaction (:store-controller (get-con instance)) (loop for slot-def in (class-slots class) unless (initialize-from-initarg slot-def) when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq) unless (slot-boundp-using-class class instance slot-def) do (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) (funcall initfun)))))))) ;; ;; CLASS REDEFINITION PROTOCOL ;; (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) ;; Update new persistent slots, the others we get for free (same oid!) ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) )) ;; ;; CLASS CHANGE PROTOCOL ;; (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) (let* ((old-class (class-of previous)) (new-class (class-of current)) (new-persistent-slots (set-difference (persistent-slots new-class) (persistent-slots old-class))) (raw-retained-persistent-slots (intersection (persistent-slots new-class) (persistent-slots old-class))) (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots when (not (persistent-slot-boundp (get-con previous) previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (with-transaction (:store-controller (get-con current)) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class current slot-def) (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def)))))) ;; Delete this instance from its old class index, if exists (when (indexed old-class) (remove-kv (oid previous) (find-class-index old-class))) (call-next-method))) ;; ;; SLOT ACCESS PROTOCOLS ;; (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name))) (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) (if (indexed class) (indexed-slot-writer class instance slot-def new-value) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer (get-con instance) new-value instance name)))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp (get-con instance) instance name))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) "Checks if the slot exists in the database." (declare (optimize (speed 3))) (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))))) (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." (declare (optimize (speed 3))) ;; NOTE: call remove-indexed-slot here instead? (when (indexed slot-def) (unregister-indexed-slot class (slot-definition-name slot-def))) (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp 2007/01/16 00:55:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; serializer.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :elephant) (defpackage :elephant-serializer2 (:use :cl :elephant :elephant-memutil) (:import-from :elephant *circularity-initial-hash-size* *resourced-byte-spec* get-cached-instance slot-definition-allocation slot-definition-name compute-slots oid)) (in-package :elephant-serializer2) (declaim (inline int-byte-spec serialize deserialize slots-and-values deserialize-bignum)) (uffi:def-type foreign-char :char) ;; Constants (defconstant +fixnum+ 1) (defconstant +fixnum64+ 2) (defconstant +char+ 3) (defconstant +single-float+ 4) (defconstant +double-float+ 5) (defconstant +negative-bignum+ 6) (defconstant +positive-bignum+ 7) (defconstant +rational+ 8) ;; Save constants by splitting strings and encoding (defconstant +utf8-string+ 9) (defconstant +utf16-string+ 10) (defconstant +utf32-string+ 11) ;; String-based aggregates (defconstant +pathname+ 12) (defconstant +symbol+ 13) ;; Cached symbol references (defconstant +symbol-id+ 14) ;; stored by id+classname (defconstant +persistent+ 15) ;; Composite objects (defconstant +cons+ 16) (defconstant +hash-table+ 17) (defconstant +object+ 18) (defconstant +array+ 19) (defconstant +struct+ 20) (defconstant +class+ 21) (defconstant +nil+ #x3F) ;; Arrays (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) ;; ;; The following may be overkill, but is intended to avoid continually ;; allocating hashes each time we serialize an object. I added some ;; adaptation to keep it from dropping and re-allocating if the user ;; continually saves large collections of objects. However the ;; defaults should handle most apps just fine. The queue is useful ;; because a system with 10 threads will need 10 circularity queues if ;; it is storing large objects ;; ;; ;; Circularity Hash for Serializer ;; (defparameter *circularity-hash-queue* (make-array 20 :fill-pointer 0 :adjustable t) "Circularity ids for the serializer.") (defparameter *circularity-lock* (ele-make-lock) "Enable multiprocessor ") (defun get-circularity-hash () "Get a clean hash for object serialization" (declare (optimize (speed 3) (safety 0))) (make-hash-table :test 'eq :size *circularity-initial-hash-size*)) ;; (if (= 0 (length *circularity-hash-queue*)) ;; (make-hash-table :test 'eq :size *circularity-initial-hash-size*)) ;; (ele-with-lock (*circularity-lock*) ;; (vector-pop *circularity-hash-queue*)))) (defun release-circularity-hash (hash) "Return the hash to the queue for reuse" (declare (optimize (speed 3) (safety 0)) (type hash-table hash) (type array *circularity-hash-queue*)) nil) ;; (unless (= (hash-table-count hash) 0) ;; (clrhash hash)) ;; (ele-with-lock (*circularity-lock*) ;; (vector-push-extend hash *circularity-hash-queue*))) ;; ;; Circularity Hash for Serializer ;; (defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t) "A list of vectors used for linear deserialization. This works nicely because all ID's are written [449 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp 2007/01/16 00:55:22 1.1 [582 lines skipped]

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 16 Jan '07

16 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4094 Added Files: cross-platform.lisp serializer1.lisp serializer2.lisp unicode2.lisp Log Message: --- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; cross-platform.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :elephant) ;; This is a quick portability hack to avoid external dependencies, if we get ;; to many of these do we need to import a standard library? do we need to import 'port' or some ;; other thread layer to the elephant dependency list? (defmacro ele-without-interrupts (&body body) `(elephant-memutil::memutil-without-interrupts ,@body)) (defun ele-make-lock () #+allegro (mp::make-process-lock) #+cmu (mp:make-lock) #+sbcl (sb-thread:make-mutex) #+mcl (ccl:make-lock) #+lispworks (mp:make-lock) #-(or allegro sbcl cmu lispworks mcl) nil ) (defmacro ele-with-lock ((lock &rest ignored) &body body) (declare (ignore ignored) (ignorable lock)) #+allegro `(mp:with-process-lock (,lock) ,@body) #+cmu `(mp:with-lock-held (,lock) ,@body) #+sbcl `(sb-thread:with-mutex (,lock) ,@body) #+lispworks `(mp:with-lock (,lock) ,@body) #+mcl `(ccl:with-lock-grabbed (,lock) ,@body) #-(or allegro sbcl cmu lispworks mcl) `(progn ,@body) ) --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; serializer.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (defpackage :elephant-serializer1 (:use :cl :elephant :elephant-memutil) (:import-from :elephant *resourced-byte-spec* get-cached-instance slot-definition-allocation slot-definition-name compute-slots oid)) (in-package :elephant-serializer1) (declaim (inline int-byte-spec serialize deserialize slots-and-values deserialize-bignum)) (uffi:def-type foreign-char :char) ;; Constants (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 (defconstant +ucs1-symbol+ 9) (defconstant +ucs1-string+ 10) (defconstant +ucs1-pathname+ 11) ;; 16-bit (defconstant +ucs2-symbol+ 12) (defconstant +ucs2-string+ 13) (defconstant +ucs2-pathname+ 14) ;; 32-bit (defconstant +ucs4-symbol+ 20) (defconstant +ucs4-string+ 21) (defconstant +ucs4-pathname+ 22) (defconstant +persistent+ 15) ;; stored by id+classname (defconstant +cons+ 16) (defconstant +hash-table+ 17) (defconstant +object+ 18) (defconstant +array+ 19) (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) (defvar *lisp-obj-id* 0 "Circularity ids for the serializer.") (defvar *circularity-hash* (make-hash-table) "Circularity hash for the serializer.") (defun clear-circularity-hash () "This handles the case where we store an object with lots of object references. CLRHASH then starts to dominate performance as it has to visit ever spot in the table so we're better off GCing the old table than clearing it" (declare (optimize (speed 3) (safety 0))) (if (> (hash-table-size *circularity-hash*) 100) (setf *circularity-hash* (make-hash-table :test 'eq :size 50)) (clrhash *circularity-hash*))) (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clear-circularity-hash) (labels ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) (typecase frob (fixnum (buffer-write-byte +fixnum+ bs) (buffer-write-int frob bs)) (null (buffer-write-byte +nil+ bs)) (symbol (let ((s (symbol-name frob))) (declare (type string s) (dynamic-extent s)) (buffer-write-byte #+(and allegro ics) (etypecase s (base-string +ucs1-symbol+) ;; +ucs1-symbol+ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s (base-string +ucs1-symbol+) (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-symbol+ bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs) (let ((package (symbol-package frob))) (if package (%serialize (package-name package)) (%serialize nil))))) (string (progn (buffer-write-byte #+(and allegro ics) (etypecase frob (base-string +ucs1-string+) ;; +ucs1-string+ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob (base-string +ucs1-string+) (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-string+ bs) (buffer-write-int (byte-length frob) bs) (buffer-write-string frob bs))) (persistent (buffer-write-byte +persistent+ bs) (buffer-write-int (oid frob) bs) ;; This circumlocution is necessitated by ;; an apparent bug in SBCL 9.9 --- type-of sometimes ;; does NOT return the "proper name" of the class as the ;; CLHS says it should, but gives the class object itself, ;; which cannot be directly serialized.... (let ((tp (type-of frob))) #+(or sbcl) (if (not (symbolp tp)) (setf tp (class-name (class-of frob)))) (%serialize tp)) ) #-(and :lispworks (or :win32 :linux)) (single-float (buffer-write-byte +single-float+ bs) (buffer-write-float frob bs)) (double-float (buffer-write-byte +double-float+ bs) (buffer-write-double frob bs)) (character (buffer-write-byte +char+ bs) ;; might be wide! (buffer-write-uint (char-code frob) bs)) (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) (buffer-write-byte #+(and allegro ics) (etypecase s (base-string +ucs1-pathname+) ;; +ucs1-pathname+ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s (base-string +ucs1-pathname+) (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-pathname+ bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs))) (integer (let* ((num (abs frob)) (word-size (ceiling (/ (integer-length num) 32))) (needed (* word-size 4))) (declare (type fixnum word-size needed)) (if (< frob 0) (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) (loop for i fixnum from 0 below word-size ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons do #+(or cmu sbcl) (buffer-write-uint (%bignum-ref num i) bs) #+(or allegro lispworks openmcl) (buffer-write-uint (ldb (int-byte-spec i) num) bs)))) (rational (buffer-write-byte +rational+ bs) (%serialize (numerator frob)) (%serialize (denominator frob))) (cons (buffer-write-byte +cons+ bs) (let ((idp (gethash frob *circularity-hash*))) (if idp (buffer-write-int idp bs) (progn (buffer-write-int (incf *lisp-obj-id*) bs) (setf (gethash frob *circularity-hash*) *lisp-obj-id*) (%serialize (car frob)) (%serialize (cdr frob)))))) (hash-table (buffer-write-byte +hash-table+ bs) (let ((idp (gethash frob *circularity-hash*))) (if idp (buffer-write-int idp bs) (progn (buffer-write-int (incf *lisp-obj-id*) bs) (setf (gethash frob *circularity-hash*) *lisp-obj-id*) (%serialize (hash-table-test frob)) (%serialize (hash-table-rehash-size frob)) (%serialize (hash-table-rehash-threshold frob)) (%serialize (hash-table-count frob)) (loop for key being the hash-key of frob using (hash-value value) do (%serialize key) (%serialize value)))))) (standard-object (buffer-write-byte +object+ bs) (let ((idp (gethash frob *circularity-hash*))) (if idp (buffer-write-int idp bs) (progn (buffer-write-int (incf *lisp-obj-id*) bs) (setf (gethash frob *circularity-hash*) *lisp-obj-id*) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) (declare (dynamic-extent svs)) (%serialize (/ (length svs) 2)) (loop for item in svs do (%serialize item))))))) (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob *circularity-hash*))) (if idp (buffer-write-int idp bs) (progn (buffer-write-int (incf *lisp-obj-id*) bs) (setf (gethash frob *circularity-hash*) *lisp-obj-id*) (buffer-write-byte (logior (byte-from-array-type (array-element-type frob)) (if (array-has-fill-pointer-p frob) +fill-pointer-p+ 0) (if (adjustable-array-p frob) +adjustable-p+ 0)) bs) (let ((rank (array-rank frob))) (buffer-write-int rank bs) (loop for i fixnum from 0 below rank do (buffer-write-int (array-dimension frob i) bs))) (when (array-has-fill-pointer-p frob) (buffer-write-int (fill-pointer frob) bs)) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) bs)) (defun slots-and-values (o) (declare (optimize (speed 3) (safety 0))) (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () do (when (and (slot-boundp o slot-name) (eq :instance (slot-definition-allocation sd))) (push (slot-value o slot-name) ret) (push slot-name ret)) finally (return ret))) (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type (or null buffer-stream) buf-str)) (labels ((%deserialize (bs) (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) ((= tag +nil+) nil) ((= tag +ucs1-symbol+) (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-symbol+) (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) #+(and sbcl sb-unicode) ((= tag +ucs4-symbol+) (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) ;; (format t "ouput name = ~A~%" name) (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) ((= tag +ucs1-string+) (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-string+) (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) #+(and sbcl sb-unicode) ((= tag +ucs4-string+) (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) ;; (get-cached-instance *store-controller* (get-cached-instance sc (buffer-read-fixnum bs) (%deserialize bs))) ((= tag +single-float+) (buffer-read-float bs)) ((= tag +double-float+) (buffer-read-double bs)) ((= tag +char+) (code-char (buffer-read-uint bs))) ((= tag +ucs1-pathname+) (parse-namestring (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-pathname+) (parse-namestring (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) ""))) #+(and sbcl sb-unicode) ((= tag +ucs4-pathname+) (parse-namestring (or (buffer-read-ucs4-string bs (buffer-read-fixnum bs)) ""))) ((= tag +positive-bignum+) (deserialize-bignum bs (buffer-read-fixnum bs) t)) ((= tag +negative-bignum+) (deserialize-bignum bs (buffer-read-fixnum bs) nil)) ((= tag +rational+) (/ (the integer (%deserialize bs)) (the integer (%deserialize bs)))) ((= tag +cons+) [151 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1 [720 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 1.1 [980 lines skipped]

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

elephant-cvs January 2007