Author: ksprotte Date: Mon Feb 18 09:40:18 2008 New Revision: 2554 Added: trunk/thirdparty/cl-store_0.8.4/ trunk/thirdparty/cl-store_0.8.4/ChangeLog (contents, props changed) trunk/thirdparty/cl-store_0.8.4/abcl/ trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/acl/ trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/allegrocl/ trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/backends.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/circularities.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd (contents, props changed) trunk/thirdparty/cl-store_0.8.4/cl-store.asd (contents, props changed) trunk/thirdparty/cl-store_0.8.4/clisp/ trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/cmucl/ trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/default-backend.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/doc/ trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi (contents, props changed) trunk/thirdparty/cl-store_0.8.4/doc/index.html (contents, props changed) trunk/thirdparty/cl-store_0.8.4/doc/style.css (contents, props changed) trunk/thirdparty/cl-store_0.8.4/ecl/ trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/licence (contents, props changed) trunk/thirdparty/cl-store_0.8.4/lispworks/ trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/mcl/ trunk/thirdparty/cl-store_0.8.4/openmcl/ trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/package.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/plumbing.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/readme (contents, props changed) trunk/thirdparty/cl-store_0.8.4/sbcl/ trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/sysdef.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/tests.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/utils.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/xml-package.lisp (contents, props changed) trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp (contents, props changed) Log: added cl-store Added: trunk/thirdparty/cl-store_0.8.4/ChangeLog ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/ChangeLog Mon Feb 18 09:40:18 2008 @@ -0,0 +1,391 @@ +2007-11-23 Sean Ross <sross@common-lisp.net> + 0.8.3 + * abcl/mop.lisp: MOP support for ABCL. Thanks to szergling. + * clisp/custom.lisp: Custom Closure serialization for CLISP. Thanks to szergling. + Functions are no longer reliably serializable between implementations. + * tests.lisp: New function tests for CLISP. + +2007-10-30 Sean Ross <sross@common-lisp.net> + * cl-store.asd: Release 0.8 + +2007-09-09 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp: be lenient when parsing parts of sbcls version string. Thanks to Gustavo. + +2007-01-26 Sean Ross <sross@common-lisp.net> + * default-backend.lisp : Checked in a fix for non sb32 integers, certain + large number numbers where incorrectly serialize. + Reported by Cyrus Harmon. + * plumbing.lisp: Added a new function alias-backend and alias the backend + 'cl-store:cl-store as :cl-store + + +2007-01-23 Sean Ross <sross@common-lisp.net> + * circularities.lisp: Renamed with-grouped-serialization to with-serialization-unit + and added two keyword args to allow removal of *grouped-restore-hash* and + *grouped-store-hash* special vars as exported symbols. + * default-backend.lisp: Changed defvars of register-types to defparameters. + +2007-01-22 Sean Ross <sross@common-lisp.net> + * utils.lisp, circularities.lisp, tests.lisp + * stop store-32-bit from creating an intermediary object + which reduces the consing (on at least Lispworks 5.0 and SBCL 'Kitten of Death'). + * export 4 new symbols which allows more efficient serialization of values. + create-serialize-hash, with-grouped-serialization, *grouped-store-hash* + and *grouped-restore-hash*. + * conditionalize some forms which were preventing ABCL from running the tests. + + +2006-12-16 Sean Ross <sross@common-lisp.net> + * circularities.lisp: Bug fix from Alex Mizrahi. Change *restored-values* + to use eql as the hash test. + +2006-12-16 Sean Ross <sross@common-lisp.net> + * cl-store.asd, utils.lisp : Added preliminary support for ABCL (tested on + version 0.0.9). + +2006-12-13 Sean Ross <sross@common-lisp.net> + * utils.lisp, acl/custom.lisp, cmucl/custom.lisp, lispworks/custom.lisp + sbcl/custom/lisp, default-backend.lisp, cl-store.asd: + Committed handling for serialization of float types short, single, double and + long and handling of positive infinity, negative infinity and NaN for all + float types (this is still only for sbcl, cmucl, acl, and lispworks). + +2006-12-11 Sean Ross <sross@common-lisp.net> + * lispworks/custom.lisp: Began work on new special float creation. + * .cvsignore : Update ignorable files + +2006-10-01 Sean Ross <sross@common-lisp.net> + * utils.lisp: Fix mkstr to upcase args. + +2006-08-03 Sean Ross <sross@common-lisp.net> + * lispworks/custom.lisp: Fix float handling for Lispworks 5.0 . + * utils.lisp: changed references to compute-slots to class-slots. + * package.lisp: Removed symbols from export list that are no + longer used. + +2006-03-13 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp: Fixed sbcl structure definition + storing for versions >= 0.9.6.25 . + +2006-03-13 Sean Ross <sross@common-lisp.net> + * utils.lisp, tests.lisp, openmcl/custom.lisp: Added + support for structure object storing for OpenMCL. + Thanks to Kilian Sprotte for the code. + * default-backend.lisp, utils.lisp: Changed creation + of class initargs to use loop instead of mappend. + Removed mappend. + +2005-11-30 Sean Ross <sross@common-lisp.net> + * package.lisp: Added imports for MCL (from Gary King) + * backends.lisp: Changed definition of the defstore-? and + defrestore-? macros to work with lispworks dspecs. + * default-backend.lisp: Fixed the *sbcl-readtable* to copy + the default readtable. + * plumbing.lisp: Changed cl-store-error to extend directly from error + and removed error from restore-error and store-error's precedence list. + +2005-10-06 Sean Ross <sross@common-lisp.net> + * backends.lisp: Fixed type definition for + compatible-magic-numbers from integer to list. + Reported by Bryan O'Connor. + +2005-10-04 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp: sb-kernel:instance is no + longer a class (since 0.9.5.3 or so). Fixed + definition of *sbcl-struct-inherits* to work + with or without this class. + Reported by Rafał Strzaliński. + +2005-09-20 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Changed storing and restoring + of standard-object to not create unnecessary garbage. + +2005-09-09 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Altered list serialization to store + all types of lists (proper, dotted and circular) in N time, + thanks to Alain Picard for parts of the code. + +2005-09-01 Sean Ross <sross@common-lisp.net> + Version 0.6 Release. + * cl-store.asd, package.lisp: Added support for the new release + of CLISP with a MOP. + * default-backend.lisp: Fixed storing of long lists. + (Reported by and help by Alain Picard) + * default-backend.lisp: New magic number, due to the + change in approach of storing lists, although previous + files can still be restored. + +2005-05-18 Sean Ross <sross@common-lisp.net> + * utils.lisp: Removed awhen + * backends.lisp: Added a compatible-magic-numbers slot. + * default-backend.lisp: misc cleanups. + New magic number (can still restore previous versions files). + +2005-05-06 Sean Ross <sross@common-lisp.net> + * backends.lisp: Added optional errorp argument + to find-backend (default false). + * default-backend.lisp: Changed simple-string storing + to keep the upgraded-array-element-type of the + restored string the same as the string which was stored. + This seems to give a performance boost (more in memory usage) + with SBCL and Lispworks. + * circularities.lisp: Stopped binding *stored-values* + and *restored-values* when circularity checking is inhibited. + * doc/cl-store.texi: Miscellaneous fixes. + +2005-05-05 Sean Ross <sross@common-lisp.net> + * all: After much experimentation with Lispworks I + discovered that globally declaiming unsafe code is + not a good idea. Changed to per function declarations. + * default-backend.lisp: Removed lispworks unicode string + test as it was incorrect. + +2005-03-24 Sean Ross <sross@common-lisp.net> + * backends.lisp, circularities.lisp, tests.lisp: + Added test gensym.2 which crashed in previous + versions (pre 0.5.7). Symbols are now tested + for eq-ality when storing. + int-sym-or-char-p renamed to int-or-char-p. + * plumbing.lisp: Added error to the superclasses + of restore-error and store-error. + +2005-03-23 Sean Ross <sross@common-lisp.net> + * backends.lisp: Fix up for type specifications + for the old-magic-numbers and stream-type slots + for class backend, reported by Kilian Sprotte. + * circularities.lisp: Changed *store-hash-size* and + *restore-hash-size* to more reasonable values (50). + +2005-03-17 Sean Ross <sross@common-lisp.net> + * doc/cl-store.texi: Fixed up to work properly with makeinfo. + +2005-03-15 Sean Ross <sross@common-lisp.net> + * default-backend.lisp, utils.lisp: Changed reference + to array-dimension-limit in array storing to + array-total-size limit. + * default-backend.lisp: Added an implementation specific + test to determine whether or not a string contains unicode + characters. + +2005-02-26 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Fixed internal-store-object + for the hash-table class (argument order was messed). + +2005-02-18 Sean Ross <sross@common-lisp.net> + Version 0.5 Release. + * utils.lisp, package.lisp: Took a lesson from the MOP + and changed serializable-slots to call the new GF + serializable-slots-using-class. + +2005-02-17 Sean Ross <sross@common-lisp.net> + * package.lisp, utils.lisp, default-backend.lisp: Patch + from Thomas Stenhaug which changed get-slot-details to + a generic-function so that it can be customized. + Added serializable-slots (returns a list of slot-definitions) + which can be overridden to customize which slots are + serialized when storing clos instances. + +2005-02-16 Sean Ross <sross@common-lisp.net> + * default-backend.lisp, package.lisp, plumbing.lisp: Patch + from Thomas Stenhaug which adds more comprehensive package + storing. + +2005-02-14 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Applied patch from Thomas Stenhaug + to default null superclasses of a restored class to + standard-object as this caused errors in Lispworks. + +2005-02-11 Sean Ross <sross@common-lisp.net> + New Magic Number for cl-store-backend. + * default-backend.lisp, acl/custom.lisp, lispworks/custom.lisp + * sbcl/custom.lisp, cmucl/custom.lisp: + Changed storing of floats to be compatible between implementations + while ensuring that NaN floats and friends are still serializable. + * backends.lisp, plumbing.lisp: + Added concept of backend designators which can be a + symbol (the backend name) or the backend itself. These are + acceptable replacements for a backend object + to store, restore and with-backend. + Completely changed argument order for generic functions + to ensure that backends are the first argument. + * ecl/mop.lisp: Added support for ecl. + * plumbing.lisp: Removed multiple-value-store (I don't really + see the point of it). + * backends.lisp: Changed the working of object restoration + from functions in a hash-table (restorer-funs of a backend) + to generic functions specialized on backend and a symbol, + removed find-function-for-type. + * plumbing.lisp: Changed the handling of the stream-type + of backends to be any legal type designator since it's + only used when opening files. + * backends.lisp: Both defstore-? and defrestore-? + can take an optional qualifer argument. + +2005-02-03 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Fixed hash-table restoration, + it no longer assumes that the result of hash-table-test + is a symbol but treats it as a function designator. + * default-backend.lisp: Added various declarations + to help improve speed. + +2005-02-01 Sean Ross <sross@common-lisp.net> + * various: Large patch which has removed pointless + argument-precedence-order from various gf's, added the + start of support for ecl, renamed fix-clisp.lisp file to + mop.lisp, and changed resolving-object and setting + to use delays allowing get-setf-place and *postfix-setters* + to be removed. + +2004-12-02 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp, cmucl/custom.lisp: Changed the evals when restoring + structure definitions to (funcall (compile nil ...)) + * cl-store-xml.asd: Removed + * cl-store-xml.noasd: Added (xml-backend is officially nuked). + +2004-11-26 Sean Ross <sross@common-lisp.net> + * cmucl/custom.lisp: Custom structure definition storing for CMUCL. + * plumbing.lisp: Bind *read-eval* to nil inside store and restore. + +2004-11-24 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: New Magic Number (Breaks backwards compatibility) + * cl-store.asd New Version 0.4 + * default-backend.lisp: Changed symbol storing to be smarter + with symbols with no home package. + * sbcl/custom.lisp: Support for structure definitions from defstruct. + * tests.lisp: Tests for structure definitions. + * circularities.lisp: Optimization for referrers and values-object's. + Added *store-hash-size* and *restore-hash-size* which can be bound + to reduce the calls to rehash which conses like crazy. + Added *check-for-circs* which can be bound to nil to stop + checking for circularities which reduces consing drastically but objects + will not be eq and will hang on circular objects (see README). + * default-backend.lisp: New Magic Number ,again. + Cater for SB! package names for built-in function names + in SBCL. + +2004-11-10 Sean Ross <sross@common-lisp.net> + New Version: 0.3.6 New Magic Number (Breaks backwards compatibility) + * default-backend.lisp: Storing for functions and generic functions. + * tests.lisp: Tests for functions and GF's. + * plumbing.lisp, circularities.lisp, default-backend.lisp: + Optimized int-sym-or-char-p. + * clisp/fix-clisp.lisp: Added generic-function-name. + * package.lisp: Import generic-function-name. + * default-backend.lisp: More optimizations for strings and ints. + +2004-11-03 Sean Ross <sross@common-lisp.net> + * tests.lisp: Added tests for unicode strings and symbols. + * default-backend.lisp: We definitely support unicode now. + Added small optimization to stop the size of files from + ballooning. + +2004-11-01 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: Changed storing of sizes of integers + and strings from store-32-bit to store-object. Changed all + instances of store-32-byte to store-32-bit. + Added a simple function storing method. + New Magic Number + * docs/cl-store.texi: New documentation. + * lispworks/custom.lisp: Custom storing for conditions + to ignore class allocated slots. + +2004-10-21 Sean Ross <sross@common-lisp.net> + * package.lisp, acl/custom.lisp: Added support for Allegro CL. + +2004-10-13 Sean Ross <sross@common-lisp.net> + * cl-store.asd: New Version (0.3) + * circularities.lisp, default-backend.lisp, xml-backend.lisp: + Changed referrer representation to a structure. + Removed cl-store-referrer package. + +2004-10-12 Sean Ross <sross@common-lisp.net> + * lispworks/custom.lisp, lispworks/custom-xml.lisp, default-backend.lisp: + Added support for NaN floats. + * tests.lisp: Test NaN floats, Test multiple values. + * default-backend.lisp: fix typo which broke clisp support. + +2004-10-11 Sean Ross <sross@common-lisp.net> + * default-backend: Added multiple-value-store. + * xml-backend: Added support for multiple return values. + +2004-10-07 Sean Ross <sross@common-lisp.net> + * circularities.lisp: Added support for multiple return values from + functions defined with defrestore-?. + +2004-10-06 Sean Ross <sross@common-lisp.net> + * cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend + into it's own package files. + * xml-backend.lisp, sbcl/custom-xml.lisp, cmucl/custom-xml.lisp, lispworks/custom-xml.lisp: + Added support for infinite floats to sbcl, cmucl and lispworks. + * xml-backend.lisp, default-backend.lisp: + Fixed floating point contagion warning signalled by clisp. + * plumbing.lisp: Changed error handing to signal a store-error or restore-error + inside a handler-bind and leave the original error unhandled. + * docs/: Rudimentary Documentation. + +2004-10-05 Sean Ross <sross@common-lisp.net> + * default-backend.lisp: New Magic number. + * backends.lisp: Changed with-backend to take a variable instead of a backend name. + * backends.lisp, plumbing.lisp: Added previous magic number field to backends and + an appropriate error if an incompatible magic number is read. + * circularities.lisp, plumbing.lisp: Removed check-stream-element-type. + * default-backend.lisp: Added a small optimization for 32 byte integers and + support for symbols with unicode strings as names. + +2004-10-04 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp: Custom float storing (supports inifinities). + * cmucl/custom.lisp: Custom float storing (supports inifinities). + * xml-backend.lisp, tests.xml: Deprecated xml-backend. + +2004-10-01 Sean Ross <sross@common-lisp.net> + * lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard. + * tests.lisp: Infinite float tests for lispworks. + +2004-09-27 Sean Ross <sross@common-lisp.net> + * plumbing.lisp: Slightly nicer error handling (I think). + All conditions caught in store and restore are resignalled + and rethrown as a store or restore error respectively. + +2004-09-01 Sean Ross <sross@common-lisp.net> + * sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing. + * cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing. + * lispworks/custom.lisp, lispworks/custom-xml.lisp: Custom structure storing + for Lispworks from Alain Picard. + * test.lisp: Enabled structure tests for Lispworks. + +2004-07-29 Sean Ross <sross@common-lisp.net> + * cl-store.asd: New version (0.2) + * sbcl/sockets.lisp: Removed. + * store.lisp: Removed. + * backends.lisp: New file for creating backends (Idea from Robert Sedgewick). + * circularities.lisp: Much changes, now works properly. + * default-backend.lisp: New file contains storing definitions + from store.lisp. Changes to simple-string storing, magic-number changed. + * plumbing.lisp: New file, framework stuff. + * xml-backend.lisp: New file. New backend for writing out Common-Lisp + objects in xml format. + * tests.lisp : More and more tests. + +2004-06-04 Sean Ross <sross@common-lisp.net> + * circularities.lisp: spelling fix. + * cl-store.asd: Specialized operation-done-p to stop some errors in asdf. + * package.lisp: Imports for openmcl from Robert Sedgewick, + Along with extra imports for cmucl. + +2004-05-21 Sean Ross <sross@common-lisp.net> + * store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp, + * tests.lisp, utils.lisp, cl-store.asd: + Added ability to specify the type code of an object + when using defstore. Added code to autogenerate the + accessor methods for CLISP when restoring classes. + EQ floats are now restored correctly. + +2004-05-18 Sean Ross <sross@common-lisp.net> + * store.lisp, fix-clisp.lisp, sbcl/sockets.lisp: + Added fix for sbcl to use non-blocking IO when working with sockets. + Created directory structure and moved fix-clisp + +2004-05-17 Sean Ross <sross@common-lisp.net> + * store.lisp, fast-io.lisp, circularities.lisp, package.lisp, + fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp: + Initial import Added: trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,29 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +(defmacro use-primitive (partial-name) + (let* ((pname (symbol-name partial-name)) + (standard-name (symbolicate "SLOT-DEFINITION-" pname)) + (primitive (find-symbol + (format nil "%SLOT-DEFINITION-~a" pname) + :system))) + `(defmethod ,standard-name (slotdef) + (,primitive slotdef)))) + +(use-primitive name) +(use-primitive allocation) +(use-primitive initform) +(use-primitive initargs) +(use-primitive readers) +(use-primitive writers) + +(defun class-slots (object) + (system:%class-slots object)) + +;; This doesn't seem to be available in ABCL +(defmethod slot-definition-type (slotdef) + t) + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,29 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +(defun setup-special-floats () + (flet ((short-float-values () + (list (cons 'excl::*infinity-single* +short-float-inf+) + (cons 'excl::*negative-infinity-single +short-float-neg-inf+) + (cons 'excl::*nan-single* +short-float-nan+))) + (single-float-values () + (list (cons 'excl::*infinity-single* +single-float-inf+) + (cons 'excl::*negative-infinity-single +single-float-neg-inf+) + (cons 'excl::*nan-single* +single-float-nan+))) + (double-float-values () + (list (cons 'excl::*infinity-double*+double-float-inf+) + (cons 'excl::*negative-infinity-double* +double-float-neg-inf+) + (cons 'excl::*nan-double* +double-float-nan+))) + (long-float-values () + (list (cons 'excl::*infinity-double* +long-float-inf+) + (cons 'excl::*negative-infinity-double* +long-float-neg-inf+) + (cons 'excl::*nan-double* +long-float-nan+)))) + (setf *special-floats* + (append (short-float-values) + (single-float-values) + (double-float-values) + (long-float-values))))) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,29 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +(defun setup-special-floats () + (flet ((short-float-values () + (list (cons #.excl::*infinity-single* +short-float-inf+) + (cons #.excl::*negative-infinity-single* +short-float-neg-inf+) + (cons #.excl::*nan-single* +short-float-nan+))) + (single-float-values () + (list (cons #.excl::*infinity-single* +single-float-inf+) + (cons #.excl::*negative-infinity-single* +single-float-neg-inf+) + (cons #.excl::*nan-single* +single-float-nan+))) + (double-float-values () + (list (cons #.excl::*infinity-double* +double-float-inf+) + (cons #.excl::*negative-infinity-double* +double-float-neg-inf+) + (cons #.excl::*nan-double* +double-float-nan+))) + (long-float-values () + (list (cons #.excl::*infinity-double* +long-float-inf+) + (cons #.excl::*negative-infinity-double* +long-float-neg-inf+) + (cons #.excl::*nan-double* +long-float-nan+)))) + (setf *special-floats* + (append (short-float-values) + (single-float-values) + (double-float-values) + (long-float-values))))) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/backends.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/backends.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,166 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; CL-STORE now has a concept of backends. +;; store and restore now take an optional backend as an +;; argument to do the actual restoring. Examples of use are +;; in default-backend.lisp and xml-backend.lisp + +(in-package :cl-store) + +(defun required-arg (name) + (error "~S is a required argument" name)) + +(defclass backend () + ((name :accessor name :initform "Unknown" :initarg :name :type symbol) + (magic-number :accessor magic-number :initarg :magic-number :type integer) + (compatible-magic-numbers :accessor compatible-magic-numbers + :initarg :compatible-magic-numbers :type list) + (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers + :type list) + (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons) + :initform (required-arg :stream-type))) + (:documentation "Core class which custom backends must extend")) + +(deftype backend-designator () + `(or symbol backend)) + +(defparameter *registered-backends* nil + "An assoc list mapping backend-names to the backend objects") + +(defun find-backend (name &optional errorp) + (declare (type symbol name)) + "Return backup called NAME. If there is no such backend NIL is returned +if ERRORP is false, otherwise an error is signalled." + (or (cdr (assoc name *registered-backends*)) + (if errorp + (error "Backend named ~S does not exist." name) + nil))) + +(defun backend-designator->backend (designator) + (check-type designator backend-designator) + (etypecase designator + (symbol (find-backend designator t)) + (backend designator))) + + +#+lispworks +(defun get-store-macro (name) + "Return the defstore-? macro which will be used by a custom backend" + (let ((macro-name (symbolicate 'defstore- name))) + `(defmacro ,macro-name ((var type stream &optional qualifier) + &body body) + (with-gensyms (gbackend) + `(dspec:def (,',macro-name (,var ,type ,stream)) + (defmethod internal-store-object ,@(if qualifier (list qualifier) nil) + ((,gbackend ,',name) (,var ,type) ,stream) + ,(format nil "Definition for storing an object of type ~A with ~ + backend ~A" type ',name) + (declare (ignorable ,gbackend)) + ,@body)))))) + +#-lispworks +(defun get-store-macro (name) + "Return the defstore-? macro which will be used by a custom backend" + (let ((macro-name (symbolicate 'defstore- name))) + `(defmacro ,macro-name ((var type stream &optional qualifier) + &body body) + (with-gensyms (gbackend) + `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil) + ((,gbackend ,',name) (,var ,type) ,stream) + ,(format nil "Definition for storing an object of type ~A with ~ + backend ~A" type ',name) + (declare (ignorable ,gbackend)) + ,@body))))) + +#+lispworks +(defun get-restore-macro (name) + "Return the defrestore-? macro which will be used by a custom backend" + (let ((macro-name (symbolicate 'defrestore- name))) + `(defmacro ,macro-name ((type place &optional qualifier) &body body) + (with-gensyms (gbackend gtype) + `(dspec:def (,',macro-name (,type ,place)) + (defmethod internal-restore-object ,@(if qualifier (list qualifier) nil) + ((,gbackend ,',name) (,gtype (eql ',type)) (,place t)) + (declare (ignorable ,gbackend ,gtype)) + ,@body)))))) + +#-lispworks +(defun get-restore-macro (name) + "Return the defrestore-? macro which will be used by a custom backend" + (let ((macro-name (symbolicate 'defrestore- name))) + `(defmacro ,macro-name ((type place &optional qualifier) &body body) + (with-gensyms (gbackend gtype) + `(defmethod internal-restore-object ,@(if qualifier (list qualifier) nil) + ((,gbackend ,',name) (,gtype (eql ',type)) (,place t)) + (declare (ignorable ,gbackend ,gtype)) + ,@body))))) + + +(defun register-backend (name class magic-number stream-type old-magic-numbers + compatible-magic-numbers) + (declare (type symbol name)) + (let ((instance (make-instance class + :name name + :magic-number magic-number + :old-magic-numbers old-magic-numbers + :compatible-magic-numbers compatible-magic-numbers + :stream-type stream-type))) + (if (assoc name *registered-backends*) + (cerror "Redefine backend" "Backend ~A is already defined." name) + (push (cons name instance) *registered-backends*)) + instance)) + +(defun alias-backend (old alias) + (let ((backend (find-backend old t))) + (pushnew (cons alias backend) *registered-backends* + :test #'equalp) + t)) + +(defun get-class-form (name fields extends) + `(defclass ,name ,extends + ,fields + (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)." + name)))) + + +#+lispworks +(defun get-dspec-alias-and-parser (name) + (let ((store-name (symbolicate 'defstore- name)) + (restore-name (symbolicate 'defrestore- name))) + `( (dspec:define-dspec-alias ,store-name (arglist) + `(method cl-store::internal-store-object ,arglist)) + (dspec:define-form-parser ,store-name (arglist) + `(,,store-name ,arglist)) + + (dspec:define-dspec-alias ,restore-name (arglist) + `(method cl-store::internal-restore-object ,arglist)) + + (dspec:define-form-parser ,restore-name (arglist) + `(,,restore-name ,arglist))))) + + +(defmacro defbackend (name &key (stream-type ''(unsigned-byte 8)) + (magic-number nil) fields (extends '(backend)) + (old-magic-numbers nil) (compatible-magic-numbers nil)) + "Defines a new backend called NAME. Stream type must be either 'char or 'binary. +FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will +be written down stream as verification and checked on restoration. +EXTENDS is a class to extend, which must be backend or a class which extends +backend" + (assert (symbolp name)) + `(eval-when (:load-toplevel :execute) + (eval-when (:compile-toplevel :load-toplevel :execute) + #+lispworks ,@(get-dspec-alias-and-parser name) + ,(get-class-form name fields extends) + ,(get-store-macro name) + ,(get-restore-macro name)) + (register-backend ',name ',name ,magic-number + ,stream-type ',old-magic-numbers ',compatible-magic-numbers))) + +(defmacro with-backend (backend &body body) + "Run BODY with *default-backend* bound to BACKEND" + `(let* ((*default-backend* (backend-designator->backend ,backend))) + ,@body)) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/circularities.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/circularities.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,260 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; Defines a special backend type which specializes various methods +;; in plumbing.lisp to make it nice and easy to +;; resolve possible circularities in objects. +;; Most of the work is done using the resolving-object +;; macro which knows how to handle an object which +;; is a referrer to a previously restored value. +;; Backends wanting to make use of this should take +;; a look at default-backend.lisp and xml-backend.lisp +;; paying special attention to the defbackend form and the +;; defrestore definitions for cons, array, simple-vector +;; array and hash-table. +;; +;; As a note this will ignore integers, symbols or characters +;; as referrer values. It will handle all other EQ number although +;; software depending on eq numbers are not conforming +;; programs according to the Hyperspec(notes in EQ). + +(in-package :cl-store) + +(defvar *check-for-circs* t) + +(defstruct delay + value (completed nil)) + +(defmacro delay (&rest body) + `(make-delay :value #'(lambda () ,@body))) + +(defun force (delay) + (unless (delay-completed delay) + (setf (delay-value delay) (funcall (the function (delay-value delay))) + (delay-completed delay) t)) + (delay-value delay)) + + +;; The definitions for setting and setting-hash sits in resolving-object. +(defmacro setting (place get) + "Resolve the possible referring object retrieved by GET and + set it into PLACE. Only usable within a resolving-object form." + (declare (ignore place get)) + #+ecl nil + #-ecl (error "setting can only be used inside a resolving-object form.")) + +(defmacro setting-hash (getting-key getting-value) + "Insert the value retrieved by GETTING-VALUE with the key + retrieved by GETTING-KEY, resolving possible circularities. + Only usable within a resolving-object form." + (declare (ignore getting-key getting-value)) + #+ecl nil + #-ecl (error "setting-hash can only be used inside a resolving-object form.")) + +(defmacro resolving-object ((var create) &body body) + "Execute body attempting to resolve circularities found in + form CREATE." + (with-gensyms (value key) + `(macrolet ((setting (place getting) + `(let ((,',value ,getting)) + (if (referrer-p ,',value) + (if *check-for-circs* + (push (delay (setf ,place + (referred-value ,',value + *restored-values*))) + *need-to-fix*) + (restore-error "Found a circular values with *check-for-circs* = nil")) + (setf ,place ,',value)))) + (setting-hash (getting-key getting-place) + `(let ((,',key ,getting-key)) + (if (referrer-p ,',key) + (let ((,',value ,getting-place)) + (unless *check-for-circs* + (restore-error "Found a circular values with *check-for-circs* = nil")) + (push (delay (setf (gethash (referred-value ,',key *restored-values*) + ,',var) + (if (referrer-p ,',value) + (referred-value ,',value *restored-values*) + ,',value))) + *need-to-fix*)) + (setting (gethash ,',key ,',var) ,getting-place))))) + (let ((,var ,create)) + ,@body + ,var)))) + +(defstruct referrer val) + +(defun referred-value (referrer hash) + "Return the value REFERRER is meant to be by looking in HASH." + (gethash (referrer-val referrer) + hash)) + +(defclass resolving-backend (backend) + () + (:documentation "A backend which does the setup for resolving circularities.")) + +(declaim (type (or fixnum null) *stored-counter*)) +(defvar *stored-counter*) +(defvar *stored-values*) + +(defvar *store-hash-size* 50) + +(defvar *grouped-store-hash*) +(defvar *grouped-restore-hash*) + +(defun create-serialize-hash () + (make-hash-table :test #'eql :size *store-hash-size*)) + +(defmacro with-serialization-unit ((&key store-hash restore-hash) + &body body) + "Executes body in a single serialization unit allowing various internal data +structures to be reused. +The keys store-hash and restore-hash are expected to be either nil or +hash-tables as produced by the function create-serialize-hash." + `(let ((*grouped-store-hash* (or ,store-hash (create-serialize-hash))) + (*grouped-restore-hash* (or ,restore-hash (create-serialize-hash)))) + ,@body)) + +(defun get-store-hash () + (when *check-for-circs* + (if (boundp '*grouped-store-hash*) + (clrhash *grouped-store-hash*) + (create-serialize-hash)))) + +(defun get-restore-hash () + (when *check-for-circs* + (if (boundp '*grouped-restore-hash*) + (clrhash *grouped-restore-hash*) + (create-serialize-hash)))) + +(defmethod backend-store :around ((backend resolving-backend) (place t) (obj t)) + (call-next-method)) + +(defmethod backend-store ((backend resolving-backend) (place stream) (obj t)) + "Store OBJ into PLACE. Does the setup for counters and seen values." + (declare (optimize speed (safety 1) (debug 0))) + (let ((*stored-counter* 0) + (*stored-values* (get-store-hash))) + (store-backend-code backend place) + (backend-store-object backend obj place) + obj)) + +(defun seen (obj) + "Has this object already been stored?" + (declare (optimize speed (safety 0) (debug 0))) + (incf *stored-counter*) + (gethash obj *stored-values*)) + +(defun update-seen (obj) + "Register OBJ as having been stored." + (declare (optimize speed (safety 0) (debug 0))) + (setf (gethash obj *stored-values*) *stored-counter*) + nil) + +(deftype not-circ () + "Type grouping integers and characters, which we + don't bother to check if they have been stored before" + '(or integer character)) + +(defun needs-checkp (obj) + "Do we need to check if this object has been stored before?" + (not (typep obj 'not-circ))) + +(defgeneric store-referrer (backend obj place) + (:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.") + (:method ((backend resolving-backend) (obj t) (place t)) + (store-error "store-referrer must be specialized for backend ~(~A~)." + (name backend)))) + + +(defun get-ref (obj) + (declare (optimize speed (safety 0) (debug 0))) + (if (needs-checkp obj) + (multiple-value-bind (val win) (seen obj) + (if (or val win) + val + (update-seen obj))) + nil)) + +(defmethod backend-store-object ((backend resolving-backend) (obj t) (place t)) + "Store object if we have not seen this object before, otherwise retrieve + the referrer object for it and store that using store-referrer." + (aif (and *check-for-circs* (get-ref obj)) + (store-referrer backend it place) + (internal-store-object backend obj place))) + +;; Restoration. +(declaim (type (or fixnum null) *restore-counter*)) +(defvar *restore-counter*) +(defvar *need-to-fix*) +(defvar *restored-values*) +(defvar *restore-hash-size* 50) + +(defmethod backend-restore ((backend resolving-backend) (place stream)) + "Restore an object from PLACE using BACKEND. Does the setup for + various variables used by resolving-object." + (let ((*restore-counter* 0) + (*need-to-fix* nil) + (*restored-values* (get-restore-hash))) + (check-magic-number backend place) + (prog1 + (backend-restore-object backend place) + (dolist (fn *need-to-fix*) + (force fn))))) + +(defun update-restored (spot val) + (declare (optimize speed (safety 0) (debug 0))) + (setf (gethash spot *restored-values*) val)) + +(defun handle-normal (backend reader place) + (declare (optimize speed (safety 1) (debug 0))) + (let ((spot (incf *restore-counter*)) + (vals (new-val (internal-restore-object backend reader place)))) + (update-restored spot vals) + vals)) + +(defgeneric referrerp (backend reader) + (:method ((backend t) (reader t)) + (error "referrerp must be specialized for backend ~A." (name backend)))) + +(defun handle-restore (place backend) + (declare (optimize speed (safety 1) (debug 0))) + (let ((reader (get-next-reader backend place))) + (declare (type symbol reader)) + (cond ((referrerp backend reader) + (incf *restore-counter*) + (new-val (internal-restore-object backend reader place))) + ((not (int-or-char-p backend reader)) + (handle-normal backend reader place)) + (t (new-val (internal-restore-object backend reader place)))))) + +(defmethod backend-restore-object ((backend resolving-backend) (place t)) + "Retrieve a object from PLACE, does housekeeping for circularity fixing." + (declare (optimize speed (safety 1) (debug 0))) + (if *check-for-circs* + (handle-restore place backend) + (call-next-method))) + +; This used to be called int-sym-or-char-p +; but was renamed to handle eq symbols (gensym's mainly). +; The basic concept is that we don't bother +; checking for circularities with integers or +; characters since these aren't gauranteed to be eq +; even if they are the same object. +; (notes for eq in CLHS). +(defgeneric int-or-char-p (backend fn) + (:method ((backend backend) (fn symbol)) + "Is function FN registered to restore an integer or character in BACKEND." + (member fn '(integer character)))) + +(defun new-val (val) + "Tries to get a referred value to reduce unnecessary cirularity fixing." + (declare (optimize speed (safety 1) (debug 0))) + (if (referrer-p val) + (multiple-value-bind (new-val win) (referred-value val *restored-values*) + (if (or new-val win) + new-val + val)) + val)) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd Mon Feb 18 09:40:18 2008 @@ -0,0 +1,69 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK. +(in-package #:cl-user) + +(defpackage #:cl-store-xml.system + (:use #:cl #:asdf)) + +(in-package #:cl-store-xml.system) + +(defclass non-required-file (cl-source-file) () + (:documentation + "File containing implementation dependent code which may or may not be there.")) + +(defun lisp-system-shortname () + #+mcl mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl) + +(defmethod component-pathname ((component non-required-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +(defmethod perform ((op compile-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + +(defmethod perform ((op load-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + +(defmethod operation-done-p ((o operation) (c non-required-file)) + (when (probe-file (component-pathname c)) + (call-next-method))) + + +(defsystem cl-store-xml + :name "CL-STORE-XML" + :author "Sean Ross <sdr@jhb.ucs.co.za>" + :maintainer "Sean Ross <sdr@jhb.ucs.co.za>" + :description "Xml Backend for cl-store" + :version "0.2.9" + :licence "MIT" + :components ((:file "xml-package") + (:file "xml-backend" :depends-on ("xml-package")) + (:non-required-file "custom-xml" :depends-on ("xml-backend"))) + :depends-on (:cl-store :xmls)) + +(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store-xml)))) + (provide 'cl-store-xml)) + +(defmethod perform ((op test-op) (sys (eql (find-system :cl-store-xml)))) + (oos 'load-op :cl-store-xml-tests) + (oos 'test-op :cl-store-xml-tests)) + +(defsystem cl-store-xml-tests + :components ((:file "xml-tests")) + :depends-on (cl-store-tests cl-store-xml)) + +(defmethod perform ((op test-op) + (sys (eql (find-system :cl-store-xml-tests)))) + (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS") + (symbol-value (find-symbol "*XML-BACKEND*" "CL-STORE-XML"))) + (error "Test-op Failed."))) + + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/cl-store.asd ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/cl-store.asd Mon Feb 18 09:40:18 2008 @@ -0,0 +1,75 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. +(in-package #:cl-user) + +(defpackage #:cl-store.system + (:use #:cl #:asdf) + (:export #:non-required-file)) + + +(in-package #:cl-store.system) + +#-(or lispworks mcl cmu clisp sbcl allegro ecl openmcl abcl) +(error "This is an unsupported lisp implementation. +Currently only MCL, OpenMCL, Lispworks, CMUCL, SBCL, +CLISP, ECL and AllegroCL are supported.") + +(defclass non-required-file (cl-source-file) () + (:documentation + "File containing implementation dependent code which may or may not be there.")) + +(defun lisp-system-shortname () + #+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl + #+allegro :acl #+ecl :ecl #+openmcl :openmcl #+abcl :abcl) + +(defmethod component-pathname ((component non-required-file)) + (let ((pathname (call-next-method)) + (name (string-downcase (lisp-system-shortname)))) + (merge-pathnames + (make-pathname :directory (list :relative name)) + pathname))) + +(defmethod perform ((op compile-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + +(defmethod perform ((op load-op) (component non-required-file)) + (when (probe-file (component-pathname component)) + (call-next-method))) + +(defmethod operation-done-p ((o operation) (c non-required-file)) + (when (probe-file (component-pathname c)) + (call-next-method))) + +(defsystem cl-store + :name "CL-STORE" + :author "Sean Ross <sross@common-lisp.net>" + :maintainer "Sean Ross <sross@common-lisp.net>" + :version "0.8.4" + :description "Serialization package" + :long-description "Portable CL Package to serialize data" + :licence "MIT" + :serial t + :components ((:file "package") + (:file "utils") + #+(or abcl (and clisp (not mop))) + (:file "mop") + (:file "backends") + (:file "plumbing") + (:file "circularities") + (:file "default-backend") + (:non-required-file "custom"))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store)))) + (funcall (find-symbol "SETUP-SPECIAL-FLOATS" :cl-store)) + (provide 'cl-store)) + +(defmethod perform ((op test-op) (sys (eql (find-system :cl-store)))) + (oos 'load-op :cl-store-tests) + (oos 'test-op :cl-store-tests)) + +(defsystem cl-store-tests + :depends-on (rt cl-store) + :components ((:file "tests"))) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,51 @@ +(in-package :cl-store) + +(defun cl-function-p (fn) + (eql #.(find-package :cl) + (symbol-package (nth-value 2 (function-lambda-expression fn))))) + +(defstore-cl-store (obj function stream) + (if (cl-function-p obj) + (dump-builtin-function obj stream) + (dump-closure obj stream))) + +(defun dump-builtin-function (obj stream) + (output-type-code +built-in-function-code+ stream) + (store-object (get-function-name obj) stream)) + +(defun dump-closure (obj stream) + (output-type-code +function-code+ stream) + (flet ((so (object) + (store-object object stream))) + (mapc #'so (multiple-value-list (function-lambda-expression obj))) + (if (compiled-function-p obj) + (flet ((es (func) ;; extract-and-store + (store-object (funcall func obj) stream))) + (mapc #'es + (list #'sys::closure-consts + #'sys::closure-codevec + #'sys::closure-documentation + #'sys::closure-lambda-list))) + (dotimes (i 4) (so nil))))) + +(defrestore-cl-store (function stream) + (flet ((ro () (restore-object stream))) + (let ((lambda-exp (ro)) + (closure-p (ro)) + (name (ro)) + (consts (ro)) + (codevec (ro)) + (doc (ro)) + (lambda-list (ro))) + (declare (ignore closure-p)) + (if codevec ;; compiled + ;; TODO What is a suitable default seclass? Currently () + (sys::%make-closure name codevec consts () lambda-list doc) + ;; TODO Any functions to do this programmatically? How to + ;; store/restore dynamic, lexical, etc environment. + (eval lambda-exp))))) + +(defrestore-cl-store (built-in-function stream) + (fdefinition (restore-object stream))) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,72 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +;; this is such a pain. + +(defgeneric slot-definition-name (slot)) +(defgeneric slot-definition-allocation (slot)) + +(defmethod slot-definition-name ((slot vector)) + (aref slot 0)) + +(defmethod slot-definition-allocation ((slot vector)) + (if (keywordp (aref slot 4)) + :instance + :class)) + + +(defun compute-slots (class) + (std-compute-slots class)) + +(defun slot-definition-x (val slot) + (cadr (member val slot))) + + +(defmethod slot-definition-allocation ((slot cons)) + (or (slot-definition-x :allocation slot) + :instance)) + +(defmethod slot-definition-initargs ((slot cons)) + (slot-definition-x :initargs slot)) + +(defmethod slot-definition-name ((slot cons)) + (slot-definition-x :name slot)) + +(defmethod slot-definition-readers ((slot cons)) + (slot-definition-x :readers slot)) + +(defmethod slot-definition-writers ((slot cons)) + (slot-definition-x :writers slot)) + +(defmethod slot-definition-type ((slot cons)) + (or (slot-definition-x :type slot) + t)) + +(defun class-direct-superclasses (class) + (or (clos::class-direct-superclasses class) + (list (find-class 'standard-object)))) + + +(defun add-methods-for-class (class vals) + (let ((readers (mappend #'(lambda (x) + (second (member :readers x))) + vals)) + (writers (mappend #'(lambda (x) + (second (member :writers x))) + vals))) + (loop for x in readers do + (eval `(defmethod ,x ((clos::object ,class)) + (slot-value clos::object ',x)))) + (loop for x in writers do + (eval `(defmethod ,x (clos::new-value (clos::object ,class)) + (setf (slot-value clos::object ',x) clos::new-value)))) + (find-class class))) + +(defmethod generic-function-name ((gf generic-function)) + (multiple-value-bind (l cp name) (function-lambda-expression gf) + (declare (ignore l cp)) + name)) + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,37 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store-xml) + + +(defstore-xml (obj structure-object stream) + (with-tag ("STRUCTURE-OBJECT" stream) + (princ-and-store "CLASS" (type-of obj) stream) + (xml-dump-type-object obj stream))) + +(defrestore-xml (structure-object place) + (restore-xml-type-object place)) + + +(defstore-xml (obj single-float stream) + (with-tag ("SINGLE-FLOAT" stream) + (princ-and-store "BITS" (kernel::single-float-bits obj) + stream))) + +(defrestore-xml (single-float stream) + (kernel::make-single-float + (restore-first (get-child "BITS" stream)))) + +(defstore-xml (obj double-float stream) + (with-tag ("DOUBLE-FLOAT" stream) + (princ-and-store "HIGH-BITS" (kernel::double-float-high-bits obj) + stream) + (princ-and-store "LOW-BITS" (kernel::double-float-low-bits obj) + stream))) + +(defrestore-xml (double-float stream) + (kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream)) + (restore-first (get-child "LOW-BITS" stream)))) + + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,119 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +; special floats +(defun create-float-values (value &rest codes) + "Returns a alist of special float to float code mappings." + (ext:with-float-traps-masked (:overflow :invalid) + (let ((neg-inf (expt value 3))) + (mapcar 'cons + (list (expt (abs value) 2) + neg-inf + (/ neg-inf neg-inf)) + codes)))) + +;; Custom Structures +(defstore-cl-store (obj structure-object stream) + (output-type-code +structure-object-code+ stream) + (store-type-object obj stream)) + +(defrestore-cl-store (structure-object stream) + (restore-type-object stream)) + +;; Structure definitions +(defun get-layout (obj) + (slot-value obj 'pcl::wrapper)) + +(defun get-info (obj) + (declare (type kernel:layout obj)) + (slot-value obj 'ext:info)) + +(defun dd-name (dd) + (slot-value dd 'kernel::name)) + +(defvar *cmucl-struct-inherits* + (list (get-layout (find-class t)) + (get-layout (find-class 'kernel:instance)) + (get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits) + 'list) + *cmucl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring +(defun cmu-struct-defs (dd) + (append (kernel::define-constructors dd) + (kernel::define-raw-accessors dd) + (kernel::define-class-methods dd))) + +(defun create-make-foo (dd) + (let ((*compile-print* nil)) + (funcall (compile nil `(lambda () ,@(cmu-struct-defs dd)))) + (find-class (dd-name dd)))) + +(defun cmu-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (kernel::%defstruct dd supers) + ;; compiler stuff + ;;(kernel::%compiler-defstruct dd) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (cmu-define-structure dd (if supers + (coerce (append *cmucl-struct-inherits* + supers) + 'vector) + (coerce *cmucl-struct-inherits* 'vector))))) + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/default-backend.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/default-backend.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,787 @@ +7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; The cl-store backend. +(in-package :cl-store) + +(defbackend cl-store :magic-number 1395477571 + :stream-type '(unsigned-byte 8) + :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155 + 1349740876 1884506444 1347643724 1349732684 1953713219 + 1416850499) + :extends (resolving-backend) + :fields ((restorers :accessor restorers + :initform (make-hash-table :size 100)))) + +(defun register-code (code name &optional (errorp nil)) + (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp) + (error "Code ~A is already defined for ~A." code name) + (setf (gethash code (restorers (find-backend 'cl-store))) + name)) + code) + + +;; Type code constants +(defparameter +referrer-code+ (register-code 1 'referrer)) +(defparameter +special-float-code+ (register-code 2 'special-float)) +(defparameter +unicode-string-code+ (register-code 3 'unicode-string)) +(defparameter +integer-code+ (register-code 4 'integer)) +(defparameter +simple-string-code+ (register-code 5 'simple-string)) +(defparameter +float-code+ (register-code 6 'float)) +(defparameter +ratio-code+ (register-code 7 'ratio)) +(defparameter +character-code+ (register-code 8 'character)) +(defparameter +complex-code+ (register-code 9 'complex)) +(defparameter +symbol-code+ (register-code 10 'symbol)) +(defparameter +cons-code+ (register-code 11 'cons)) +(defparameter +pathname-code+ (register-code 12 'pathname)) +(defparameter +hash-table-code+ (register-code 13 'hash-table)) +(defparameter +standard-object-code+ (register-code 14 'standard-object)) +(defparameter +condition-code+ (register-code 15 'condition)) +(defparameter +structure-object-code+ (register-code 16 'structure-object)) +(defparameter +standard-class-code+ (register-code 17 'standard-class)) +(defparameter +built-in-class-code+ (register-code 18 'built-in-class)) +(defparameter +array-code+ (register-code 19 'array)) +(defparameter +simple-vector-code+ (register-code 20 'simple-vector)) +(defparameter +package-code+ (register-code 21 'package)) +(defparameter +simple-byte-vector-code+ (register-code 22 'simple-byte-vector)) + +;; fast storing for 32 bit ints +(defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer)) +(defparameter +built-in-function-code+ (register-code 25 'built-in-function)) +(defparameter +function-code+ (register-code 26 'function nil)) +(defparameter +gf-code+ (register-code 27 'generic-function nil)) + +;; Used by SBCL and CMUCL. +(defparameter +structure-class-code+ (register-code 28 'structure-class)) +(defparameter +struct-def-code+ (register-code 29 'struct-def)) + +(defparameter +gensym-code+ (register-code 30 'gensym)) + +(defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string)) +(defparameter +simple-base-string-code+ (register-code 35 'simple-base-string)) + +;; setups for type code mapping +(defun output-type-code (code stream) + (declare (type ub32 code)) + (write-byte (ldb (byte 8 0) code) stream)) + +(declaim (inline read-type-code)) +(defun read-type-code (stream) + (read-byte stream)) + +(defmethod referrerp ((backend cl-store) (reader t)) + (declare (optimize speed (safety 0) (space 0) (debug 0))) + (eql reader 'referrer)) + +(defparameter *restorers* (restorers (find-backend 'cl-store))) + +;; get-next-reader needs to return a symbol which will be used by the +;; backend to lookup the function that was defined by +;; defrestore-cl-store to restore it, or nil if not found. +(defun lookup-code (code) + (declare (optimize speed (safety 0) (space 0) (debug 0))) + (gethash code *restorers*)) + +(defmethod get-next-reader ((backend cl-store) (stream stream)) + (declare (optimize speed (safety 0) (space 0) (debug 0))) + (let ((type-code (read-type-code stream))) + (or (lookup-code type-code) + (error "Type code ~A is not registered." type-code)))) + + +;; referrer, Required for a resolving backend +(defmethod store-referrer ((backend cl-store) (ref t) (stream t)) + (output-type-code +referrer-code+ stream) + (dump-int ref stream)) + +(defrestore-cl-store (referrer stream) + (make-referrer :val (undump-int stream))) + + + +;; integers +;; The theory is that most numbers will fit in 32 bits +;; so we we have a little optimization for it + +;; We need this for circularity stuff. +(defmethod int-or-char-p ((backend cl-store) (type symbol)) + (declare (optimize speed (safety 0) (space 0) (debug 0))) + (or (eql type '32-bit-integer) + (eql type 'integer) + (eql type 'character))) + +(defstore-cl-store (obj integer stream) + (declare (optimize speed (safety 1) (debug 0))) + (if (typep obj 'sb32) + (store-32-bit-integer obj stream) + (store-arbitrary-integer obj stream))) + +(defun dump-int (obj stream) + (declare (optimize speed (safety 0) (debug 0))) + (etypecase obj + ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream)) + ((unsigned-byte 32) (write-byte 2 stream) (store-32-bit obj stream)))) + +(defun undump-int (stream) + (declare (optimize speed (safety 0) (debug 0))) + (ecase (read-byte stream) + (1 (read-byte stream)) + (2 (read-32-bit stream nil)))) + +(defun store-32-bit-integer (obj stream) + (declare (optimize speed (safety 1) (debug 0)) (type sb32 obj)) + (output-type-code +32-bit-integer-code+ stream) + (write-byte (if (minusp obj) 1 0) stream) + (dump-int (abs obj) stream)) + +(defrestore-cl-store (32-bit-integer stream) + (declare (optimize speed (safety 1) (debug 0))) + (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-) + (undump-int stream))) + + +(defun num->bits (num ) + (loop for val = (abs num) then (ash val -8 ) + for count from 0 + until (zerop val) + collect (logand val #XFF) into bits + finally (return (values bits count)))) + +(defun store-arbitrary-integer (obj stream) + (declare (type integer obj) (stream stream) + (optimize speed)) + (output-type-code +integer-code+ stream) + (multiple-value-bind (bits count) (num->bits obj) + (store-object (if (minusp obj) (- count) count) + stream) + (dolist (x bits) (store-32-bit x stream)))) + + +(defrestore-cl-store (integer buff) + (declare (optimize speed)) + (let ((count (restore-object buff))) + (loop repeat (abs count) + with sum = 0 + for pos from 0 by 8 + for bit = (read-32-bit buff nil) + finally (return (if (minusp count) (- sum) sum)) + :do + (incf sum (* bit (expt 2 pos)))))) + + + +(defun bits->num (bits) + (loop with sum = 0 + for pos from 0 by 8 + for bit in bits + finally (return sum) + :do (incf sum (* bit (expt 2 pos))))) + + + +;; Floats (*special-floats* are setup in the custom.lisp files) + +(defconstant +short-float-inf+ 0) +(defconstant +short-float-neg-inf+ 1) +(defconstant +short-float-nan+ 2) + +(defconstant +single-float-inf+ 3) +(defconstant +single-float-neg-inf+ 4) +(defconstant +single-float-nan+ 5) + +(defconstant +double-float-inf+ 6) +(defconstant +double-float-neg-inf+ 7) +(defconstant +double-float-nan+ 8) + +(defconstant +long-float-inf+ 9) +(defconstant +long-float-neg-inf+ 10) +(defconstant +long-float-nan+ 11) + +(defvar *special-floats* nil) + +;; Implementations are to provide an implementation for the create-float-value +;; function +(defun create-float-values (value &rest codes) + "Returns a alist of special float to float code mappings." + (declare (ignore value codes)) + nil) + +(defun setup-special-floats () + (setf *special-floats* + (nconc (create-float-values most-negative-short-float +short-float-inf+ + +short-float-neg-inf+ +short-float-nan+) + (create-float-values most-negative-single-float +single-float-inf+ + +single-float-neg-inf+ +single-float-nan+) + (create-float-values most-negative-double-float +double-float-inf+ + +double-float-neg-inf+ +double-float-nan+) + (create-float-values most-negative-long-float +long-float-inf+ + +long-float-neg-inf+ +long-float-nan+)))) + +(defstore-cl-store (obj float stream) + (declare (optimize speed)) + (block body + (let (significand exponent sign) + (handler-bind (((or simple-error arithmetic-error type-error) + #'(lambda (err) + (declare (ignore err)) + (when-let (type (cdr (assoc obj *special-floats*))) + (output-type-code +special-float-code+ stream) + (write-byte type stream) + (return-from body))))) + (multiple-value-setq (significand exponent sign) + (integer-decode-float obj)) + (output-type-code +float-code+ stream) + (write-byte (float-type obj) stream) + (store-object significand stream) + (store-object (float-radix obj) stream) + (store-object exponent stream) + (store-object sign stream))))) + +(defrestore-cl-store (float stream) + (float (* (the float (get-float-type (read-byte stream))) + (* (the integer (restore-object stream)) + (expt (the integer (restore-object stream)) + (the integer (restore-object stream)))) + (the integer (restore-object stream))))) + +(defrestore-cl-store (special-float stream) + (or (car (rassoc (read-byte stream) *special-floats*)) + (restore-error "Float ~S is not a valid special float."))) + + +;; ratio +(defstore-cl-store (obj ratio stream) + (output-type-code +ratio-code+ stream) + (store-object (numerator obj) stream) + (store-object (denominator obj) stream)) + +(defrestore-cl-store (ratio stream) + (/ (the integer (restore-object stream)) + (the integer (restore-object stream)))) + +;; chars +(defstore-cl-store (obj character stream) + (output-type-code +character-code+ stream) + (store-object (char-code obj) stream)) + +(defrestore-cl-store (character stream) + (code-char (restore-object stream))) + +;; complex +(defstore-cl-store (obj complex stream) + (output-type-code +complex-code+ stream) + (store-object (realpart obj) stream) + (store-object (imagpart obj) stream)) + +(defrestore-cl-store (complex stream) + (complex (restore-object stream) + (restore-object stream))) + +;; symbols +(defstore-cl-store (obj symbol stream) + (declare (optimize speed)) + (cond ((symbol-package obj) + (output-type-code +symbol-code+ stream) + (store-object (symbol-name obj) stream) + (store-object (package-name (symbol-package obj)) + stream)) + ;; Symbols with no home package + (t (output-type-code +gensym-code+ stream) + (store-object (symbol-name obj) stream)))) + +(defrestore-cl-store (symbol stream) + (values (intern (restore-object stream) + (restore-object stream)))) + +(defrestore-cl-store (gensym stream) + (make-symbol (restore-object stream))) + + +;; Lists +(defun dump-list (list length last stream) + (declare (optimize speed (safety 1) (debug 0)) + (type cons list)) + (output-type-code +cons-code+ stream) + (store-object length stream) + (loop repeat length + for x on list do + (store-object (car x) stream)) + (store-object last stream)) + +(defun restore-list (stream) + (declare (optimize speed (safety 1) (debug 0))) + (let* ((conses (restore-object stream)) + (ret ()) + (tail ret)) + (dotimes (x conses) + (let ((obj (restore-object stream))) + ;; we can't use setting here since we wan't to + ;; be fairly efficient when adding objects to the + ;; end of the list. + (when (and *check-for-circs* (referrer-p obj)) + (let ((x x)) + (push (delay (setf (nth x ret) + (referred-value obj *restored-values*))) + *need-to-fix*))) + (if ret + (setf (cdr tail) (list obj) + tail (cdr tail)) + (setf ret (list obj) + tail (last ret))))) + (let ((last1 (restore-object stream))) + ;; and check for the last possible circularity + (if (and *check-for-circs* (referrer-p last1)) + (push (delay (setf (cdr tail) + (referred-value last1 *restored-values*))) + *need-to-fix*) + (setf (cdr tail) last1))) + ret)) + +(defstore-cl-store (list cons stream) + (multiple-value-bind (length last) (safe-length list) + (dump-list list length last stream))) + +(defrestore-cl-store (cons stream) + (restore-list stream)) + + +;; pathnames +(defstore-cl-store (obj pathname stream) + (output-type-code +pathname-code+ stream) + (store-object #-sbcl (pathname-host obj) + #+sbcl (host-namestring obj) stream) + (store-object (pathname-device obj) stream) + (store-object (pathname-directory obj) stream) + (store-object (pathname-name obj) stream) + (store-object (pathname-type obj) stream) + (store-object (pathname-version obj) stream)) + +(defrestore-cl-store (pathname stream) + (make-pathname + :host (restore-object stream) + :device (restore-object stream) + :directory (restore-object stream) + :name (restore-object stream) + :type (restore-object stream) + :version (restore-object stream))) + + +;; hash tables +(defstore-cl-store (obj hash-table stream) + (declare (optimize speed)) + (output-type-code +hash-table-code+ stream) + (store-object (hash-table-rehash-size obj) stream) + (store-object (hash-table-rehash-threshold obj) stream) + (store-object (hash-table-size obj) stream) + (store-object (hash-table-test obj) stream) + (store-object (hash-table-count obj) stream) + (loop for key being the hash-keys of obj + using (hash-value value) do + (store-object key stream) + (store-object value stream))) + +(defrestore-cl-store (hash-table stream) + (let ((rehash-size (restore-object stream)) + (rehash-threshold (restore-object stream)) + (size (restore-object stream)) + (test (restore-object stream)) + (count (restore-object stream))) + (declare (type integer count size)) + (let ((hash (make-hash-table :test test + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :size size))) + (resolving-object (x hash) + (loop repeat count do + ;; Unfortunately we can't use the normal setting here + ;; since there could be a circularity in the key + ;; and we need to make sure that both objects are + ;; removed from the stream at this point. + (setting-hash (restore-object stream) + (restore-object stream)))) + hash))) + +;; The dumping of objects works by serializing the type of the object which +;; is followed by applicable slot-name and value (depending on whether the +;; slot is bound, it's allocation and *store-class-slots*). Once each slot +;; is serialized a counter is incremented which is stored at the end. +;; When restoring the object a new instance is allocated and then +;; restore-type-object starts reading objects from the stream. +;; If the restored object is a symbol the it names a slot and it's value +;; is pulled out and set on the newly allocated object. +;; If the restored object is an integer then this is the end marker +;; for the object and the number of slots restored is checked against +;; this counter. + +;; Object and Conditions +(defun store-type-object (obj stream) + (declare (optimize speed)) + (let ((all-slots (serializable-slots obj)) + (length 0)) + (store-object (type-of obj) stream) + (dolist (slot all-slots) + (let ((slot-name (slot-definition-name slot))) + (when (and (slot-boundp obj slot-name) + (or *store-class-slots* + (not (eql (slot-definition-allocation slot) + :class)))) + (store-object (slot-definition-name slot) stream) + (store-object (slot-value obj slot-name) stream) + (incf length)))) + (store-object length stream))) + +(defstore-cl-store (obj standard-object stream) + (output-type-code +standard-object-code+ stream) + (store-type-object obj stream)) + +(defstore-cl-store (obj condition stream) + (output-type-code +condition-code+ stream) + (store-type-object obj stream)) + +(defun restore-type-object (stream) + (declare (optimize speed)) + (let* ((class (find-class (restore-object stream))) + (new-instance (allocate-instance class))) + (resolving-object (obj new-instance) + (loop for count from 0 do + (let ((slot-name (restore-object stream))) + (etypecase slot-name + (integer (assert (= count slot-name) (count slot-name) + "Number of slots restored does not match slots stored.") + (return)) + (symbol + ;; slot-names are always symbols so we don't + ;; have to worry about circularities + (setting (slot-value obj slot-name) (restore-object stream))))))) + new-instance)) + +(defrestore-cl-store (standard-object stream) + (restore-type-object stream)) + +(defrestore-cl-store (condition stream) + (restore-type-object stream)) + + +;; classes +(defstore-cl-store (obj standard-class stream) + (output-type-code +standard-class-code+ stream) + (store-object (class-name obj) stream) + (store-object (mapcar #'get-slot-details (class-direct-slots obj)) + stream) + (store-object (mapcar (if *store-class-superclasses* + #'identity + #'class-name) + (class-direct-superclasses obj)) + stream) + (store-object (type-of obj) stream)) + +(defrestore-cl-store (standard-class stream) + (let* ((class (restore-object stream)) + (slots (restore-object stream)) + (supers (restore-object stream)) + (meta (restore-object stream)) + (keywords '(:direct-slots :direct-superclasses + :metaclass)) + (final (loop for keyword in keywords + for slot in (list slots + (or supers (list 'standard-object)) + meta) + nconc (list keyword slot)))) + (cond ((find-class class nil) + (cond (*nuke-existing-classes* + (apply #'ensure-class class final) + #+(and clisp (not mop)) (add-methods-for-class class slots)) + (t (find-class class)))) + (t (apply #'ensure-class class final) + #+(and clisp (not mop)) (add-methods-for-class class slots))))) + +;; built in classes + +(defstore-cl-store (obj built-in-class stream) + (output-type-code +built-in-class-code+ stream) + (store-object (class-name obj) stream)) + +#-ecl ;; for some reason this doesn't work with ecl +(defmethod internal-store-object ((backend cl-store) (obj (eql (find-class 'hash-table))) stream) + (output-type-code +built-in-class-code+ stream) + (store-object 'cl:hash-table stream)) + +(defrestore-cl-store (built-in-class stream) + (find-class (restore-object stream))) + + +;; Arrays, vectors and strings. +(defstore-cl-store (obj array stream) + (declare (optimize speed (safety 1) (debug 0))) + (typecase obj + (simple-base-string (store-simple-base-string obj stream)) + (simple-string (store-simple-string obj stream)) + (simple-vector (store-simple-vector obj stream)) + ((simple-array (unsigned-byte 8) (*)) (store-simple-byte-vector obj stream)) + (t (store-array obj stream)))) + + +(defun store-array (obj stream) + (declare (optimize speed (safety 0) (debug 0)) + (type array obj)) + (output-type-code +array-code+ stream) + (if (and (= (array-rank obj) 1) + (array-has-fill-pointer-p obj)) + (store-object (fill-pointer obj) stream) + (store-object nil stream)) + (store-object (array-element-type obj) stream) + (store-object (adjustable-array-p obj) stream) + (store-object (array-dimensions obj) stream) + (dolist (x (multiple-value-list (array-displacement obj))) + (store-object x stream)) + (store-object (array-total-size obj) stream) + (loop for x from 0 below (array-total-size obj) do + (store-object (row-major-aref obj x) stream))) + + + + +(defrestore-cl-store (array stream) + (declare (optimize speed (safety 1) (debug 0))) + (let* ((fill-pointer (restore-object stream)) + (element-type (restore-object stream)) + (adjustable (restore-object stream)) + (dimensions (restore-object stream)) + (displaced-to (restore-object stream)) + (displaced-offset (restore-object stream)) + (size (restore-object stream)) + (res (make-array dimensions + :element-type element-type + :adjustable adjustable + :fill-pointer fill-pointer))) + (declare (type cons dimensions) (type array-tot-size size)) + (when displaced-to + (adjust-array res dimensions :displaced-to displaced-to + :displaced-index-offset displaced-offset)) + (resolving-object (obj res) + (loop for x from 0 below size do + (let ((pos x)) + (setting (row-major-aref obj pos) (restore-object stream))))))) + +(defun store-simple-vector (obj stream) + (declare (optimize speed (safety 0) (debug 0)) + (type simple-vector obj)) + (output-type-code +simple-vector-code+ stream) + (store-object (length obj) stream) + (loop for x across obj do + (store-object x stream))) + +(defrestore-cl-store (simple-vector stream) + (declare (optimize speed (safety 1) (debug 0))) + (let* ((size (restore-object stream)) + (res (make-array size))) + (declare (type array-size size)) + (resolving-object (obj res) + (dotimes (i size) + ;; we need to copy the index so that + ;; it's value at this time is preserved. + (let ((x i)) + (setting (aref obj x) (restore-object stream))))) + res)) + +(defun store-simple-byte-vector (obj stream) + (declare (optimize speed (safety 0) (debug 0)) + (type (simple-array (unsigned-byte 8) (*)) obj)) + (output-type-code +simple-byte-vector-code+ stream) + (store-object (length obj) stream) + (loop for x across obj do + (write-byte x stream))) + +(defrestore-cl-store (simple-byte-vector stream) + (declare (optimize speed (safety 1) (debug 0))) + (let* ((size (restore-object stream)) + (res (make-array size :element-type '(unsigned-byte 8)))) + (declare (type array-size size)) + (resolving-object (obj res) + (dotimes (i size) + ;; we need to copy the index so that + ;; it's value at this time is preserved. + (let ((x i)) + (setting (aref obj x) (read-byte stream))))) + res)) + +;; Dumping (unsigned-byte 32) for each character seems +;; like a bit much when most of them will be +;; base-chars. So we try to cater for them. +(defvar *char-marker* (code-char 255) + "Largest character that can be represented in 8 bits") + +(defun unicode-string-p (string) + "An implementation specific test for a unicode string." + (declare (optimize speed (safety 0) (debug 0)) + (type simple-string string)) + #+cmu nil ;; cmucl doesn't support unicode yet. + #+lispworks (not (typep string 'lw:8-bit-string)) + #-(or cmu lispworks) (some #'(lambda (x) (char> x *char-marker*)) string)) + +(defun store-simple-string (obj stream) + (declare (type simple-string obj) + (optimize speed (safety 1) (debug 0))) + (cond ((unicode-string-p obj) + (output-type-code +unicode-string-code+ stream) + (dump-string #'dump-int obj stream)) + (t (output-type-code +simple-string-code+ stream) + (dump-string #'write-byte obj stream)))) + +(defun store-simple-base-string (obj stream) + (declare (type simple-string obj) + (optimize speed (safety 1) (debug 0))) + (cond ((unicode-string-p obj) + (output-type-code +unicode-base-string-code+ stream) + (dump-string #'dump-int obj stream)) + (t (output-type-code +simple-base-string-code+ stream) + (dump-string #'write-byte obj stream)))) + +(defun dump-string (dumper obj stream) + (declare (simple-string obj) (function dumper) (stream stream) + (optimize speed (safety 1) (debug 0))) + (dump-int (the array-size (length obj)) stream) + (loop for x across obj do (funcall dumper (char-code x) stream))) + +(defrestore-cl-store (simple-string stream) + (declare (optimize speed)) + (undump-string #'read-byte 'character stream)) + +(defrestore-cl-store (unicode-string stream) + (declare (optimize speed)) + (undump-string #'undump-int 'character stream)) + +(defrestore-cl-store (simple-base-string stream) + (declare (optimize speed)) + (undump-string #'read-byte 'base-char stream)) + +(defrestore-cl-store (unicode-base-string stream) + (declare (optimize speed)) + (undump-string #'undump-int 'base-char stream)) + +(defun undump-string (reader type stream) + (declare (type function reader) (type stream stream) + (optimize speed (safety 1) (debug 0))) + (let* ((length (the array-size (undump-int stream)) ) + (res (make-string length :element-type type))) + (declare (type simple-string res)) + (dotimes (x length) + (setf (schar res x) (code-char (funcall reader stream)))) + res)) + +;; packages (from Thomas Stenhaug) +(defstore-cl-store (obj package stream) + (output-type-code +package-code+ stream) + (store-object (package-name obj) stream) + (store-object (package-nicknames obj) stream) + (store-object (mapcar (if *store-used-packages* #'identity #'package-name) + (package-use-list obj)) + stream) + (store-object (internal-symbols obj) stream) + (store-object (package-shadowing-symbols obj) stream) + (store-object (external-symbols obj) stream)) + +(defun remove-remaining (times stream) + (declare (optimize speed) (type fixnum times)) + (dotimes (x times) + (restore-object stream))) + +(defrestore-cl-store (package stream) + (let* ((package-name (restore-object stream)) + (existing-package (find-package package-name))) + (cond ((or (not existing-package) + (and existing-package *nuke-existing-packages*)) + (restore-package package-name stream :force *nuke-existing-packages*)) + (t (remove-remaining 5 stream) + existing-package)))) + +(defun internal-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0)) + (used (package-use-list package))) + (do-symbols (symbol package) + (unless (find (symbol-package symbol) used) + (vector-push-extend symbol acc))) + acc)) + +(defun external-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0))) + (do-external-symbols (symbol package) + (vector-push-extend symbol acc)) + acc)) + +(defun restore-package (package-name stream &key force) + (when (and force (find-package package-name)) + (delete-package package-name)) + (let ((package (make-package package-name + :nicknames (restore-object stream) + :use (restore-object stream)))) + (loop for symbol across (restore-object stream) do + (import symbol package)) + (shadow (restore-object stream) package) + (loop for symbol across (restore-object stream) do + (export symbol package)) + package)) + +;; Function storing hack. +;; This just stores the function name if we can find it +;; or signal a store-error. +(defun parse-name (name) + (let ((name (subseq name 21))) + (declare (type simple-string name)) + (if (search name "SB!" :end1 3) + (replace name "SB-" :end1 3) + name))) + +#+sbcl +(defvar *sbcl-readtable* (copy-readtable nil)) +#+sbcl +(set-macro-character #\# #'(lambda (c s) + (declare (ignore c s)) + (store-error "Invalid character in function name.")) + nil + *sbcl-readtable*) + +(defun get-function-name (obj) + (multiple-value-bind (l cp name) (function-lambda-expression obj) + (declare (ignore l cp)) + (cond ((and name (or (symbolp name) (consp name))) name) + ;; Try to deal with sbcl's naming convention + ;; of built in functions (pre 0.9) + #+sbcl + ((and name (stringp name) + (search "top level local call " (the simple-string name))) + (let ((new-name (parse-name name)) + (*readtable* *sbcl-readtable*)) + (unless (string= new-name "") + (handler-case (read-from-string new-name) + (error (c) + (declare (ignore c)) + (store-error "Unable to determine function name for ~A." + obj)))))) + (t (store-error "Unable to determine function name for ~A." + obj))))) + + +#-clisp +(defstore-cl-store (obj function stream) + (output-type-code +function-code+ stream) + (store-object (get-function-name obj) stream)) + +#-clisp +(defrestore-cl-store (function stream) + (fdefinition (restore-object stream))) + +;; Generic function, just dumps the gf-name +(defstore-cl-store (obj generic-function stream) + (output-type-code +gf-code+ stream) + (aif (generic-function-name obj) + (store-object it stream) + (store-error "No generic function name for ~A." obj))) + +(defrestore-cl-store (generic-function stream) + (fdefinition (restore-object stream))) + + +(setf *default-backend* (find-backend 'cl-store)) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi Mon Feb 18 09:40:18 2008 @@ -0,0 +1,796 @@ +\input texinfo @c -*- texinfo -*- +@c %**start of header +@setfilename cl-store.texi +@settitle CL-STORE Manual + + +@dircategory Software development +@direntry +* cl-store: (cl-store). CL Serialization Package +@end direntry + +@copying +Copyright @copyright{} (c) (C) 2004 Sean Ross All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors and contributors may not be used to endorse + or promote products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@end copying + +@c +@titlepage +@title CL-STORE: CL Serialization Package + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex + +@node Top +@top CL-STORE: CL Serialization Package + +@insertcopying + +@menu +* Introduction: Introduction +* Getting Started: Getting Started +* API: API +* Customizing: Customizing +* New Backends: New Backends +* Notes: Notes +* Credits: Credits +* Index:: + +@end menu + +@end ifnottex + +@node Introduction +@chapter Introduction + +CL-STORE is a portable serialization package for Common Lisp which +allows the reading and writing of most objects found in Common Lisp +resolving any circularities which it detects. It is intended to serve +the same purpose as Java's ObjectOutput and ObjectInputStream, although +it's somewhat more extensible. + +The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store} +where one can find details about mailing lists, cvs repositories and various releases. + +This documentation is for CL-STORE version 0.6 . + +Enjoy + Sean. +@section Example +@lisp +(defclass myclass () ((a :accessor a :initarg :a))) +(cl-store:store (make-instance 'myclass :a 3) "/tmp/test.out") + +(a (cl-store:restore "/tmp/test.out")) +@end lisp + + +@section Supported Objects +@itemize @bullet +@item Numbers (floats, integers, complex, NaN floats, rationals) +@item Strings (Supports Unicode Strings) +@item Characters +@item Symbols +@item Packages +@item HashTables +@item Lists +@item Vectors And Arrays +@item Instances of CLOS Classes +@item CLOS Classes +@item Structure Instances +@item Structure Definitions (CMUCL and SBCL only) +@item Functions (stores the function name) +@item Generic Functions (stores generic-function-name) +@end itemize + +@section Supported Implementations +@itemize @bullet +@item SBCL +@item CMUCL +@item CLISP +@item Lispworks +@item Allegro CL +@item OpenMCL +@item ECL +@end itemize + + +@node Getting Started +@chapter Getting Started + +CL-STORE uses @uref{http://cliki.net/asdf,,asdf} as it's system definition tool and +is required whenever you load the package. +You will need to download it, or if you have @uref{http://sbcl.org,,sbcl} +@code{(require 'asdf)} + + +@section Downloading +@itemize +@item ASDF-INSTALL +CL-STORE is available through asdf-install. If you are new +to Common Lisp this is the suggested download method. With asdf-install loaded run +@code{(asdf-install:install :cl-store)} +This will download and install the package for you. Asdf-install will try to verify +that the package signature is correct and that you trust the author. If the key is +not found or the trust level is not sufficient a continuable error will be signalled. +You can choose to ignore the error and continue to install the package. +See the documentation of asdf-install for more details. + +@item DOWNLOAD + +The latest cl-store release will always be available from @uref{http://common-lisp.net,,cl.net}. +Download and untar in an appropriate directory then symlink @file{cl-store.asd} +to a directory on @code{asdf:*central-registry*} +(see the documentation for asdf for details about setting up asdf). + +@item CVS + +If you feel the need to be on the bleeding edge you can use +anonymous CVS access, see the @uref{http://common-lisp.net/project/cl-store,,Home Page} +for more details for accessing the archive. Once downloaded follow the symlink instructions above. + +@end itemize + +@section Installing +Once downloaded and symlinked you can load CL-STORE at anytime using +@code{(asdf:oos 'asdf:load-op :cl-store)} +This will compile CL-STORE the first time it is loaded. + +@section Testing +Once installed you can run the regression tests for it. +The tests depend on the @uref{http://cliki.net/rt,,Regression Tests} + asdf package which is asdf-installable. The tests can be run be executing +@code{(asdf:oos 'asdf:test-op :cl-store)} + +If any tests fail please send a message to one of the Mailing Lists. + + +@node API +@chapter API + +@section Variables +@anchor{Variable *nuke-existing-classes*} +@vindex *nuke-existing-classes* +@deftp {Variable} *nuke-existing-classes* @emph{Default NIL} +Determines wether or not to override existing classes when restoring a CLOS Class. If +@code{*nuke-existing-classes*} is not NIL the current definition will be overridden. +@end deftp + +@anchor{Variable *store-class-superclasses*} +@vindex *store-class-superclasses* +@deftp {Variable} *store-class-superclasses* @emph{Default NIL} +If @code{*store-class-superclasses*} is not NIL when storing a CLOS Class all +superclasses will be stored. +@end deftp + +@anchor{Variable *store-class-slots*} +@vindex *store-class-slots* +@deftp {Variable} *store-class-slots* @emph{Default T} +If @code{*store-class-slots*} is NIL slots which are class allocated will +not be serialized when storing objects. +@end deftp + + +@anchor{Variable *nuke-existing-packages*} +@vindex *nuke-existing-packages* +@deftp {Variable} *nuke-existing-packages* @emph{Default NIL} +If @code{*nuke-existing-packages*} is non-nil then packages which +already exist will be deleted when restoring packages. +@end deftp + +@anchor{Variable *store-used-packages*} +@vindex *store-used-packages* +@deftp {Variable} *store-used-packages* @emph{Default NIL} +The variable determines how packages on a package use +list will be serialized. If non-nil the the package will +be fully serialized, otherwise only the name will be stored. +@end deftp + +@anchor{Variable *store-hash-size*} +@vindex *store-hash-size* +@deftp {Variable} *store-hash-size* @emph{Default 50} +The default size of the hash-table created to keep track of +objects which have already been stored. By binding the +variable to a suitable value you can avoid the consing +involved by rehashing hash-tables. +@end deftp + +@anchor{Variable *restore-hash-size*} +@vindex *restore-hash-size* +@deftp {Variable} *restore-hash-size* @emph{Default 50} +The default size of the hash-table created to keep track of +objects which have already been restored. By binding the +variable to a suitable value you can avoid the consing +involved by rehashing hash-tables. +@end deftp + + +@anchor{Variable *check-for-circs*} +@vindex *check-for-circs* +@deftp {Variable} *check-for-circs* @emph{Default t} +Binding this variable to nil when storing or restoring +an object inhibits all checks for circularities which gives a +severe boost to performance. The downside of this is that no +restored objects will be eq and attempting to store circular objects +will hang. The speed improvements are definitely worth it if you +know that there will be no circularities or shared references in +your data (eg spam-filter hash-tables). +@end deftp + +@anchor{Variable *default-backend*} +@vindex *default-backend* +@deftp {Variable} *default-backend* +The backend that will be used by default. +@end deftp + + +@section Functions +@anchor{Generic store} +@deffn {Generic} store object place &optional (backend *default-backend*) +Stores @emph{object} into @emph{place} using @emph{backend}. @emph{Place} +must be either a @code{stream} or a @code{pathname-designator}. All +conditions signalled from store can be handled by catching @code{store-error}. +If the @code{store-error} is not handled the causing error will be signalled. +@end deffn + +@anchor{Generic restore} +@deffn {Generic} restore place &optional (backend *default-backend*) +Restores an object serialized using @code{store} from @emph{place} using @emph{backend}. +@emph{Place} must be either a @code{stream} or a @code{pathname-designator}. +Restore is setffable eg. +@lisp +(store 0 "/tmp/counter") +(incf (restore "/tmp/counter")) +@end lisp +All conditions signalled from restore can be handled by catching @code{restore-error}. +If the @code{restore-error} is not handled the causing error will be signalled. +@end deffn + + +@anchor{Function find-backend} +@deffn {Function} find-backend name &optional (errorp nil) +Return backup called @emph{name}. If there is no such backend NIL is returned +if @emph{errorp} is false, otherwise an error is signalled. +@end deffn + +@anchor{Function caused-by} +@deffn {Function} caused-by cl-store-error +Returns the @code{condition} which caused @code{cl-store-error} to be signalled. +@end deffn + + +@section Macros +@anchor{Macro with-backend} +@deffn {Macro} with-backend backend &body body +Execute @emph{body} with @code{*default-backend*} bound to the +backend designated by @emph{backend}. +@end deffn + + +@section Conditions +@anchor{Condition cl-store-error} +@deftp {Condition} cl-store-error +Class Precedence: @code{condition} + +Root CL-STORE Condition all errors occuring while storing or restoring +can be handled by catching @code{cl-store-error} +@end deftp + +@anchor{Condition store-error} +@deftp {Condition} store-error +Class Precedence: @code{cl-store-error} + +A @code{store-error} will be signalled when an error occurs within +@code{store} or @code{multiple-value-store}. The causing error can be +obtained using @code{(caused-by condition)} +@end deftp + +@anchor{Condition restore-error} +@deftp {Condition} restore-error +Class Precedence: @code{cl-store-error} + +A @code{restore-error} will be signalled when an error occurs within +@code{restore}. The causing error can be obtained using +@code{(caused-by condition)} +@end deftp + + +@node Customizing +@chapter Customizing + +@section About Customizing +Each backend in CL-STORE can be customized to store various values in a +custom manner. By using the @code{defstore-<backend-name>} and +@code{defrestore-<backend-name>} macros you can define your own methods for +storing various objects. This may require a marginal understanding of the +backend you wish to extend. + +eg. +@lisp +(in-package :cl-user) + +(use-package :cl-store) + +(setf *default-backend* (find-backend 'cl-store)) + +;; Create the custom class +(defclass random-obj () ((a :accessor a :initarg :a))) + +;; Register random object. This is specific to the +;; cl-store-backend. +(defvar *random-obj-code* (register-code 110 'random-obj)) + +;; Create a custom storing method for random-obj +;; outputting the code previously registered. +(defstore-cl-store (obj random-obj stream) + (output-type-code *random-obj-code* stream) + (store-object (a obj) stream)) + +;; Define a restoring method. +(defrestore-cl-store (random-obj stream) + (random (restore-object stream))) + +;; Test it out. +(store (make-instance 'random-obj :a 10) "/tmp/random") + +(restore "/tmp/random") +=> ; some number from 0 to 9 + +@end lisp +If you need to get fancier take a look at the macroexpansion of the customizing macros. +@vskip 0pt plus 1filll + +@section Customizing API + +This API is primarily concerned with the cl-store-backend although other backends +will be similar in structure. + +@subsection Functions +@anchor{Function register-code} +@deffn {Function} register-code code name &optional (errorp t) +Registers @emph{name} under the code @emph{code} into the cl-store-backend. +The backend will use this mapping when restoring values. +Will signal an error if code is already registered and @emph{errorp} is not NIL. +Currently codes 1 through 35 are in use. +@end deffn + +@anchor{Function output-type-code} +@deffn {Function} output-type-code type-code stream +Writes @emph{type-code} into @emph{stream}. +This must be done when writing out objects so that the type of the +object can be identified on deserialization. +@end deffn + +@anchor{Function store-32-bit} +@deffn {Function} store-32-bit integer stream +Outputs the the low 32 bits from @emph{integer} into @emph{stream}. +@end deffn + +@anchor{Function read-32-bit} +@deffn {Function} read-32-bit stream +Reads a 32-bit integer from @emph{stream}. +@end deffn + +@anchor{Generic store-object} +@deffn {Generic} store-object object place +Stores @emph{object} into @emph{place}. This should be used inside +@code{defstore-cl-store} to output parts of objects. @code{store} +should not be used. +@end deffn + +@anchor{Generic restore-object} +@deffn {Generic} restore-object place +Restore an object, written out using @code{store-object} from @emph{place}. +@end deffn + +@anchor{Generic get-slot-details} +@deffn {Generic} get-slot-details slot-definition +Generic function which returns a list of slots details +which can be used as an argument to @code{ensure-class}. +Currently it is only specialized on slot-definition +@end deffn + +@anchor{Generic serializable-slots} +@deffn {Generic} serializable-slots object +Method which returns a list of slot-definition objects +which will be serialized for @emph{object}. The default +is to call @code{serializable-slots-using-class}. +@end deffn + +@anchor{Generic serializable-slots-using-class} +@deffn {Generic} serializable-slots-using-class object class +Returns a list of slot-definition objects which will +be serialized for object and class. +Example. +When serializing cl-sql objects to disk or to another +lisp session the view-database slot should not be serialized. +Instead of specializing serializable-slots for each view-class +created you can do this. +@lisp +(defmethod serializable-slots-using-class + ((object t) (class clsql-sys::standard-db-class)) + (delete 'clsql-sys::view-database (call-next-method) + :key 'slot-definition-name)) +@end lisp +@end deffn + + +@vskip 0pt plus 1filll + +@subsection Macros +@anchor{Macro defstore-cl-store} +@deffn {Macro} defstore-cl-store (var type stream &key qualifier) &body body +Create a custom storing mechanism for @emph{type} which must be a legal +Class Name. @emph{Body} will be called when an object of class @emph{type} +is stored using @code{store-object} with @emph{var} bound to the object to +be stored and @emph{stream} bound to the stream to output to. If @emph{qualifier} +is given it must be a legal qualifier to @code{defmethod}. +Example. +@lisp +(defstore-cl-store (obj ratio stream) + (output-type-code +ratio-code+ stream) + (store-object (numerator obj) stream) + (store-object (denominator obj) stream)) + +@end lisp +@end deffn + +@anchor{Macro defrestore-cl-store} +@deffn {Macro} defrestore-cl-store (type stream) &body body +Create a custom restoring mechanism for the @emph{type} +registered using @code{register-code}.@emph{Body} will be executed with +@emph{stream} being the input stream to restore an object from. + +Example. +@lisp +(defrestore-cl-store (ratio stream) + (/ (restore-object stream) + (restore-object stream))) +@end lisp +@end deffn + +@anchor{Macro resolving-object} +@deffn {Macro} resolving-object (var create) &body body +Executes @emph{body} resolving circularities detected in @emph{object}. +Resolving-object works by creating a closure, containing code to set a +particular place in @emph{object}, which is then pushed onto a list. +Once the object has been fully restored all functions on this list are called and the +circularities are resolved. +Example. +@lisp +(defrestore-cl-store (cons stream) + (resolving-object (object (cons nil nil)) + (setting (car object) (restore-object stream)) + (setting (cdr object) (restore-object stream)))) +@end lisp +@end deffn + +@vskip 0pt plus 1filll + +@anchor{Macro setting} +@deffn {Macro} setting place get +This macro can only be used inside @code{resolving-object}. It sets the value +designated by @emph{place} to @emph{get} for the object that is being resolved. + +Example. +@lisp +(defrestore-cl-store (simple-vector stream) + (let* ((size (restore-object stream)) + (res (make-array size))) + (resolving-object (object res) + (loop repeat size for i from 0 do + ;; we need to copy the index so that + ;; it's value is preserved for after the loop. + (let ((x i)) + (setting (aref object x) (restore-object stream))))) + res)) +@end lisp +@end deffn + +@anchor{Macro setting-hash} +@deffn {Macro} setting-hash getting-key getting-value +@code{setting-hash} works identically to setting although it is used +exclusively on hash-tables due to the fact that both the key and the value +being restored could be a circular reference. +Example. +@lisp +(defrestore-cl-store (hash-table stream) + (let ((rehash-size (restore-object stream)) + (rehash-threshold (restore-object stream)) + (size (restore-object stream)) + (test (restore-object stream)) + (count (restore-object stream))) + (let ((hash (make-hash-table :test (symbol-function test) + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :size size))) + (resolving-object (obj hash) + (loop repeat count do + (setting-hash (restore-object stream) + (restore-object stream)))) + hash))) +@end lisp +@end deffn + + +@node New Backends +@chapter New Backends + +@section About +You can define your own backends in cl-store to do custom object +I/O. Theoretically one can add a backend that can do socket +based communication with any language provided you know the +correct format to output objects in. If the framework is not +sufficient to add your own backend just drop me a line and +we will see what we can do about it. + + +@section The Process + +@subsection Add the backend +Use @code{defbackend} to define the new backend choosing the output +format, an optional magic number, extra fields for the backend +and a backend to extend which defaults to the base backend. +eg. (from the cl-store-backend) +@lisp +(defbackend cl-store :magic-number 1347643724 + :stream-type '(unsigned-byte 8) + :old-magic-numbers (1912923 1886611788 1347635532) + :extends resolving-backend + :fields ((restorers :accessor restorers :initform (make-hash-table)))) +@end lisp + +@subsection Recognizing Objects. +Decide how to recognize objects on restoration. +When restoring objects the backend has a responsibility +to return a symbol identifying the @code{defrestore} method +to call by overriding the @code{get-next-reader} method. +In the cl-store backend this is done by keeping a mapping of type codes to symbols. +When storing an object the type code is written down the stream first and then the restoring details for that particular object. +The @code{get-next-reader} method is then specialized to read the type code and look up the symbol in a hash-table kept +on the backend. + +eg. (from the cl-store-backend) +@lisp +(defvar *cl-store-backend* (find-backend 'cl-store)) +;; This is a util method to register the code with a symbol +(defun register-code (code name &optional (errorp t)) + (aif (and (gethash code (restorers *cl-store-backend*)) errorp) + (error "Code ~A is already defined for ~A." code name) + (setf (gethash code (restorers *cl-store-backend*)) + name)) + code) +;; An example of registering the code 7 with ratio +(defconstant +ratio-code+ (register-code 7 'ratio)) + +;; Extending the get-next-reader method +(defmethod get-next-reader ((backend cl-store) (stream stream)) + (let ((type-code (read-type-code stream))) + (or (gethash type-code (restorers backend)) + (values nil (format nil "Type ~A" type-code))))) + +(defstore-cl-store (obj ratio stream) + (output-type-code +ratio-code+ stream) ;; output the type code + (store-object (numerator obj) stream) + (store-object (denominator obj) stream)) + +@end lisp + + +@subsection Extending the Resolving backend +If you are extending the @code{resolving-backend} you have a couple of extra +responsibilities to ensure that circular references are resolved correctly. +@code{Store-referrer} must be extended for your backend to output the referrer +code. This must be done as if it were a @code{defstore} for a referrer. +A @code{defrestore-<backend-name>} must also be defined for the referrer which +must return a referrer created with @code{make-referrer}. Once that is +done you can use @code{resolving-object} and @code{setting} to resolve +circularities in objects. + +eg (from the cl-store backend) +@lisp +(defconstant +referrer-code+ (register-code 1 'referrer nil)) +(defmethod store-referrer (ref stream (backend cl-store)) + (output-type-code +referrer-code+ stream) + (store-32-bit ref stream)) + +(defrestore-cl-store (referrer stream) + (make-referrer :val (read-32-bit stream nil))) +@end lisp + +@section Example: Simple Pickle Format +As a short example we will define a backend that can handle simple objects +using the python pickle format. + +@subsection Define the backend +@lisp +(in-package :cl-user) +(use-package :cl-store) + +(defbackend pickle :stream-type 'character) +@end lisp +@vskip 0pt plus 2filll + +@subsection Recognize Objects +This is just a simple example to be able to handle single strings +stored with Python's pickle module. + +@lisp +(defvar *pickle-mapping* + '((#\S . string))) + +(defmethod get-next-reader ((backend pickle) (stream stream)) + (let ((type-code (read-char stream))) + (or (cdr (assoc type-code *pickle-mapping*)) + (values nil (format nil "Type ~A" type-code))))) + +(defrestore-pickle (noop stream)) + +(defstore-pickle (obj string stream) + (format stream "S'~A'~%p0~%." obj)) + +(defrestore-pickle (string stream) + (let ((val (read-line stream))) + (read-line stream) ;; remove the PUSH op + (read-line stream) ;; remove the END op + (subseq val 1 (1- (length val))))) +@end lisp + +@subsection Test the new Backend. +This can be tested with the code +@lisp +Python +>>> import pickle +>>> pickle.dump('Foobar', open('/tmp/foo.p', 'w')) + +Lisp +* (cl-store:restore "/tmp/foo.p" 'pickle) +=> "Foobar" +And + +Lisp +* (cl-store:store "BarFoo" "/tmp/foo.p" 'pickle) + +Python +>>> pickle.load(open('/tmp/foo.p')) +'BarFoo' +@end lisp + +@vskip 0pt plus 2filll + +@section API + +@subsection Functions +@anchor{Generic backend-restore} +@deffn {Generic} backend-restore backend place +Restore the object found in stream @emph{place} using backend @emph{backend}. +Checks the magic-number and invokes @code{backend-restore-object}. Called by @code{restore}, override +for custom restoring. +@end deffn + +@anchor{Generic backend-restore-object} +@deffn {Generic} backend-restore backend place +Find the next function to call to restore the next object with @emph{backend} and invoke it with @emph{place}. +Called by @code{restore-object}, override this method to do custom restoring (see @file{circularities.lisp} +for an example). +@end deffn + +@anchor{Generic backend-store} +@deffn {Generic} backend-store backend place obj +Stores the backend code and calls @code{store-object}. This is called by @code{store}. Override for +custom storing. +@end deffn + +@anchor{Generic backend-store-object} +@deffn {Generic} backend-store-object backend obj place +Called by @code{store-object}, override this to do custom storing +(see @file{circularities.lisp} for an example). +@end deffn + +@anchor{Generic get-next-reader} +@deffn {Generic} get-next-reader backend place +Method which must be specialized for @emph{backend} to return the next symbol +designating a @code{defrestore} instance to restore an object from @emph{place}. +If no reader is found return a second value which will be included in the error. +@end deffn + + +@subsection Macros +@anchor{Macro defbackend} +@deffn {Macro} defbackend name &key (stream-type (required-arg "stream-type")) magic-number fields (extends 'backend) old-magic-numbers +eg. @code{(defbackend pickle :stream-type 'character)} +This creates a new backend called @emph{name}, @emph{stream-type} describes the type of stream that the +backend will serialize to which must be suitable as an argument to open. @emph{Magic-number}, when present, must be of type +(unsigned-byte 32) which will be written as a verifier for the backend. @emph{Fields} are extra fields to be +added to the new class which will be created. By default the @emph{extends} keyword is @emph{backend},the root backend, but +this can be any legal backend. @emph{Old-magic-numbers} holds previous magic-numbers that have been used by the backend +to identify incompatible versions of objects stored. +@end deffn + +@node Notes +@chapter Notes + +@section Backend Designators +The @emph{backend} argument to store, restore and with-backend +is a backend designator which can be one of. +@itemize @bullet +@item A backend returned by @code{(find-backend name)} +@item A symbol designating a backend (the first argument to defbackend). +@end itemize + +@section Known Issues +@itemize @bullet +@item CLISP, OpenMCL, Allegro CL cannot store structure instances. +@item Structure definitions are only supported in SBCL and CMUCL. +@item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized. +@end itemize + +@section Delivery with Lispworks +Restoring lists in delivered images can be problematic since the tree shaker +can remove the symbol cl:nil (this seems to only happen with delivery-level > 4). +To work around this add the following keywords to the delivery call. +@lisp + :packages-to-keep '(:cl) + :keep-symbols '(cl:nil) +@end lisp + +@section Regarding String Serialization +Users are required to be extremely careful when serializing strings from one +lisp implementation to another since the array-element-type will be tracked +for strings and the Hyperspec does not specify an upper limit for base-chars. +This can be a problem if you serialize a simple-base-string containing wide +characters, in an implementation which specifies no limit on base-char, +to an implementation with a limit. +If you have a solution I would be happy to hear it. + +@node Credits +@chapter Credits +Thanks To +@itemize @bullet +@item Common-Lisp.net: For project hosting. +@item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks. +@item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends. +@item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements. +@item Killian Sprotte: Type specification fixups. +@end itemize + +@node Index +@chapter Index + +@section Function Index +@printindex fn + +@section Variable Index +@printindex vr + +@bye Added: trunk/thirdparty/cl-store_0.8.4/doc/index.html ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/doc/index.html Mon Feb 18 09:40:18 2008 @@ -0,0 +1,40 @@ +<?xml version="1.0"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>CL-STORE</title> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> +</head> + +<body> + <div class="header"> + <h1>CL-STORE</h1> + <h2>A Common Lisp Serialization Package</h2> + </div> + + + <h2>Documentation</h2> + <ul> + <li>Basic details can be found in the <a href="../README">README</a> file.</li> + <li><a href="cl-store.texi">Texinfo Manual</a></li> + <li>List of <a href="../ChangeLog">Changes</a></li> + </ul> + + + <h2>When things break (or don't work as expected)</h2> + <ul> + <li>Try a <a href="http://www.common-lisp.net/mailman/listinfo/cl-store-devel">mailing list</a></li> + <li>Drop <a href="mailto:sross@common-lisp.net">me</a> a line</li> + </ul> + + + <div class="footer"> + <address>sross@common-lisp.net</address> + </div> + + + </body> + +</html> Added: trunk/thirdparty/cl-store_0.8.4/doc/style.css ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/doc/style.css Mon Feb 18 09:40:18 2008 @@ -0,0 +1,77 @@ + +.header { + font-size: medium; + background-color:#00396D; + color:#E9B800; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} +.about { + font-size: large; + border-style:solid; + border-width: 0px; + border-color:#00396D; +} + + +.code { + font-family: monospace; + border-style:solid; + border-width: 5px; + border-color:#00396D; +} + + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#00396D; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +a:link, a:visited { + text-decoration: none; +} + +a:hover, a:active { + text-decoration: underline; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + text-decoration:underline; } Added: trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,29 @@ +(in-package :cl-store) + +(defun slot-definition-name (slot) + (nth 0 slot)) + +(defun slot-definition-allocation (slot) + (nth 6 slot)) + +(defun slot-definition-initform (slot) + (nth 2 slot)) + +(defun slot-definition-initargs (slot) + (nth 1 slot)) + +(defun slot-accessors (slot) + (nth 3 slot)) + +(defun slot-definition-writers (slot) + (append (slot-accessors slot) + (nth 5 slot))) + +(defun slot-definition-readers (slot) + (append (slot-accessors slot) + (nth 4 slot))) + +(defun slot-definition-type (slot) + (nth 7 slot)) + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/licence ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/licence Mon Feb 18 09:40:18 2008 @@ -0,0 +1,26 @@ +Copyright (c) 2004 Sean Ross +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors and contributors may not be used to endorse + or promote products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. Added: trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,63 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store-xml) + +(defstore-xml (obj structure-object stream) + (with-tag ("STRUCTURE-OBJECT" stream) + (princ-and-store "CLASS" (type-of obj) stream) + (let ((slots (structure:structure-class-slot-names (class-of obj)))) + (with-tag ("SLOTS" stream) + (dolist (slot-name slots) + (with-tag ("SLOT" stream) + (princ-and-store "NAME" slot-name stream) + (princ-and-store "VALUE" (slot-value obj slot-name) stream))))))) + +(defrestore-xml (structure-object place) + (let* ((class (find-class (restore-first (get-child "CLASS" place)))) + (new-instance (structure::allocate-instance class))) + (resolving-object new-instance + (dolist (slot (xmls:node-children (get-child "SLOTS" place))) + (let ((slot-name (restore-first (get-child "NAME" slot)))) + (setting (slot-value slot-name) + (restore-first (get-child "VALUE" slot)))))))) + + + +(defstore-xml (obj float stream) + (block body + (handler-bind ((simple-error + #'(lambda (err) + (declare (ignore err)) + (cond + ((cl-store::positive-infinity-p obj) + (with-tag ("POSITIVE-INFINITY" stream)) + (return-from body)) + ((cl-store::negative-infinity-p obj) + (with-tag ("NEGATIVE-INFINITY" stream)) + (return-from body)) + ((cl-store::float-nan-p obj) + (with-tag ("FLOAT-NAN" stream)) + (return-from body)) + (t nil))))) + (multiple-value-bind (signif exp sign) + (integer-decode-float obj) + (with-tag ("FLOAT" stream) + (princ-and-store "SIGNIFICAND" signif stream) + (princ-and-store "EXPONENT" exp stream) + (princ-and-store "SIGN" sign stream) + (princ-and-store "TYPE" (float-type obj) stream)))))) + +(defrestore-xml (positive-infinity stream) + (declare (ignore stream)) + cl-store::+positive-infinity+) + +(defrestore-xml (negative-infinity stream) + (declare (ignore stream)) + cl-store::+negative-infinity+) + +(defrestore-xml (float-nan stream) + (declare (ignore stream)) + cl-store::+nan-float+) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,37 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +;; Special float handling +(defun create-float-values (value &rest codes) + (let ((neg-inf (expt value 3))) + (mapcar 'cons + (list (expt (abs value) 2) + neg-inf + (/ neg-inf neg-inf)) + codes))) + +;; Custom structure storing from Alain Picard. +(defstore-cl-store (obj structure-object stream) + (output-type-code +structure-object-code+ stream) + (let* ((slot-names (structure:structure-class-slot-names (class-of obj)))) + (store-object (type-of obj) stream) + (store-object (length slot-names) stream) + (dolist (slot-name slot-names) + (store-object slot-name stream) + (store-object (slot-value obj slot-name) stream)))) + +(defrestore-cl-store (structure-object stream) + (let* ((class (find-class (restore-object stream))) + (length (restore-object stream)) + (new-instance (structure::allocate-instance class))) + (loop repeat length do + (let ((slot-name (restore-object stream))) + ;; slot-names are always symbols so we don't + ;; have to worry about circularities + (resolving-object (obj new-instance) + (setting (slot-value obj slot-name) (restore-object stream))))) + new-instance)) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,13 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. +(in-package :cl-store) + +(defstore-cl-store (obj structure-object stream) + (output-type-code +structure-object-code+ stream) + (store-type-object obj stream)) + +(defrestore-cl-store (structure-object stream) + (restore-type-object stream)) + + +; EOF Added: trunk/thirdparty/cl-store_0.8.4/package.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/package.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,200 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;(in-package :cl-store.system) + +(defpackage #:cl-store + (:use #:cl) + (:export #:backend #:magic-number #:stream-type + #:restorers #:resolving-backend #:find-backend #:defbackend + #:*restore-counter* #:*need-to-fix* #:*restored-values* + #:with-backend #:*default-backend* + #:*current-backend* #:*store-class-slots* + #:*nuke-existing-classes* #:*store-class-superclasses* + #:cl-store-error #:store-error #:restore-error #:store + #:restore #:backend-store #:store-backend-code #:store-object + #:backend-store-object + #:restore #:backend-restore #:cl-store #:referrerp + #:check-magic-number #:get-next-reader #:int-or-char-p + #:restore-object #:backend-restore-object #:serializable-slots + #:defstore-cl-store #:defrestore-cl-store #:register-code + #:output-type-code #:store-referrer #:resolving-object + #:internal-store-object #:setting #:simple-standard-string + #:float-type #:get-float-type #:make-referrer #:setting-hash + #:multiple-value-store #:caused-by + #:store-32-bit #:read-32-bit #:*check-for-circs* + #:*store-hash-size* #:*restore-hash-size* #:get-slot-details + #:*store-used-packages* #:*nuke-existing-packages* + #:serializable-slots-using-class + + ;; Hooks into lower level circularity tracking + ;; to reduce consing. + #:with-serialization-unit #:create-serialize-hash + + #:alias-backend) + + #+sbcl (:import-from #:sb-mop + #:generic-function-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+ecl (:import-from #:clos + #:generic-function-name + #:compute-slots + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:import-from #:pcl + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:shadowing-import-from #:pcl + #:class-name + #:find-class + #:standard-class + #:class-of) + + #+openmcl (:import-from #:openmcl-mop + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+digitool (:import-from #:ccl + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+(and clisp (not mop)) (:import-from #:clos + #:slot-value + #:std-compute-slots + #:slot-boundp + #:class-name + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:ensure-class) + + #+lispworks (:import-from #:clos + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class) + + #+(and clisp mop) (:import-from #:clos + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class) + + #+allegro (:import-from #:mop + #:generic-function-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + #+abcl (:import-from #:mop + + ;; All the commented out methods are defined in + ;; abcl/custom.lisp + + #:generic-function-name + ;;#:slot-definition-allocation + #:slot-definition + #:compute-slots + ;;#:slot-definition-initform + ;;#:slot-definition-initargs + ;;#:slot-definition-name + ;;#:slot-definition-readers + ;;#:slot-definition-type + ;;#:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + ; #:class-slots + #:ensure-class) + ) +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/plumbing.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/plumbing.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,222 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information + +;; The framework where everything hangs together. +;; + +(in-package :cl-store) + +(defvar *store-used-packages* nil + "If non-nil will serialize each used package otherwise will +only store the package name") +(defvar *nuke-existing-packages* nil + "Whether or not to overwrite existing packages on restoration.") +(defvar *nuke-existing-classes* nil + "Do we overwrite existing class definitions on restoration.") +(defvar *store-class-superclasses* nil + "Whether or not to store the superclasses of a stored class.") +(defvar *store-class-slots* t + "Whether or not to serialize slots which are class allocated.") + +(declaim (type backend *default-backend* *current-backend*)) +(defvar *default-backend*) +(defvar *current-backend*) + + +;; conditions +;; From 0.2.3 all conditions which are signalled from +;; store or restore will signal a store-error or a +;; restore-error respectively inside a handler-bind. +(defun cl-store-report (condition stream) + (declare (stream stream)) + (aif (caused-by condition) + (format stream "~A" it) + (apply #'format stream (format-string condition) + (format-args condition)))) + +(define-condition cl-store-error (error) + ((caused-by :accessor caused-by :initarg :caused-by + :initform nil) + (format-string :accessor format-string :initarg :format-string + :initform "Unknown") + (format-args :accessor format-args :initarg :format-args :initform nil)) + (:report cl-store-report) + (:documentation "Root cl-store condition")) + +(define-condition store-error (cl-store-error) + () + (:documentation "Error thrown when storing an object fails.")) + +(define-condition restore-error (cl-store-error) + () + (:documentation "Error thrown when restoring an object fails.")) + +(defun store-error (format-string &rest args) + (error 'store-error :format-string format-string :format-args args)) + +(defun restore-error (format-string &rest args) + (error 'restore-error :format-string format-string :format-args args)) + + +;; entry points +(defun store-to-file (obj place backend) + (declare (type backend backend) + (optimize speed)) + (let ((element-type (stream-type backend))) + (with-open-file (s place :element-type element-type + :direction :output :if-exists :supersede) + (backend-store backend s obj)))) + +(defgeneric store (obj place &optional designator) + (:documentation "Store OBJ into Stream PLACE using backend BACKEND.") + (:method ((obj t) (place t) &optional (designator *default-backend*)) + "Store OBJ into Stream PLACE using backend BACKEND." + (declare (optimize speed)) + (let* ((backend (backend-designator->backend designator)) + (*current-backend* backend) + (*read-eval* nil)) + (handler-bind ((error (lambda (c) + (signal 'store-error :caused-by c)))) + (backend-store backend place obj))))) + + +(defgeneric backend-store (backend place obj) + (:method ((backend backend) (place stream) (obj t)) + "The default. Checks the streams element-type, stores the backend code + and calls store-object." + (declare (optimize speed)) + (store-backend-code backend place) + (store-object obj place backend) + obj) + (:method ((backend backend) (place string) (obj t)) + "Store OBJ into file designator PLACE." + (store-to-file obj place backend)) + (:method ((backend backend) (place pathname) (obj t)) + "Store OBJ into file designator PLACE." + (store-to-file obj place backend)) + (:documentation "Method wrapped by store, override this method for + custom behaviour (see circularities.lisp).")) + +(defgeneric store-backend-code (backend stream) + (:method ((backend backend) (stream t)) + (declare (optimize speed)) + (when-let (magic (magic-number backend)) + (store-32-bit magic stream))) + (:documentation + "Store magic-number of BACKEND, when present, into STREAM.")) + +(defun store-object (obj stream &optional (backend *current-backend*)) + "Store OBJ into STREAM. Not meant to be overridden, + use backend-store-object instead" + (backend-store-object backend obj stream)) + +(defgeneric backend-store-object (backend obj stream) + (:documentation + "Wrapped by store-object, override this to do custom storing + (see circularities.lisp for an example).") + (:method ((backend backend) (obj t) (stream t)) + "The default, just calls internal-store-object." + (declare (optimize speed)) + (internal-store-object backend obj stream))) + + +(defgeneric internal-store-object (backend obj place) + (:documentation "Method which is specialized by defstore-? macros.") + (:method ((backend backend) (obj t) (place t)) + "If call falls back here then OBJ cannot be serialized with BACKEND." + (store-error "Cannot store objects of type ~A with backend ~(~A~)." + (type-of obj) (name backend)))) + +;; restoration +(defgeneric restore (place &optional backend) + (:documentation + "Restore and object FROM PLACE using BACKEND. Not meant to be + overridden, use backend-restore instead") + (:method (place &optional (designator *default-backend*)) + "Entry point for restoring objects (setfable)." + (declare (optimize speed)) + (let* ((backend (backend-designator->backend designator)) + (*current-backend* backend) + (*read-eval* nil)) + (handler-bind ((error (lambda (c) + (signal 'restore-error :caused-by c)))) + (backend-restore backend place))))) + + +(defgeneric backend-restore (backend place) + (:documentation "Wrapped by restore. Override this to do custom restoration") + (:method ((backend backend) (place stream)) + "Restore the object found in stream PLACE using backend BACKEND. + Checks the magic-number and invokes backend-restore-object" + (declare (optimize speed)) + (check-magic-number backend place) + (backend-restore-object backend place)) + (:method ((backend backend) (place string)) + "Restore the object found in file designator PLACE using backend BACKEND." + (restore-from-file place backend)) + (:method ((backend backend) (place pathname)) + "Restore the object found in file designator PLACE using backend BACKEND." + (restore-from-file place backend))) + +(defun restore-from-file (place backend) + (declare (optimize speed)) + (let ((element-type (stream-type backend))) + (with-open-file (s place :element-type element-type :direction :input) + (backend-restore backend s)))) + +(defun (setf restore) (new-val place &optional (backend *default-backend*)) + (store new-val place backend)) + +(defgeneric check-magic-number (backend stream) + (:method ((backend backend) (stream t)) + (let ((magic-number (magic-number backend))) + (declare (type (or null ub32) magic-number)) + (when magic-number + (let ((val (read-32-bit stream nil))) + (declare (type ub32 val)) + (cond ((= val magic-number) nil) + ((member val (compatible-magic-numbers backend)) + nil) + ((member val (old-magic-numbers backend)) + (restore-error "Stream contains an object stored with an ~ +incompatible version of backend ~A." (name backend))) + (t (restore-error "Stream does not contain a stored object~ + for backend ~A." + (name backend)))))))) + (:documentation + "Check to see if STREAM actually contains a stored object for BACKEND.")) + +(defun lookup-reader (val readers) + (gethash val readers)) + +(defgeneric get-next-reader (backend place) + (:documentation + "Method which must be specialized for BACKEND to return + the next function to restore an object from PLACE. + If no reader is found return a second value which will be included + in the error.") + (:method ((backend backend) (place t)) + (declare (ignore place)) + "The default, throw an error." + (restore-error "get-next-reader must be specialized for backend ~(~A~)." + (name backend)))) + +;; Wrapper for backend-restore-object so we don't have to pass +;; a backend object around all the time + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun restore-object (place &optional (backend *current-backend*)) + "Restore the object in PLACE using BACKEND" + (backend-restore-object backend place))) + +(defgeneric backend-restore-object (backend place) + (:documentation + "Find the next function to call with BACKEND and invoke it with PLACE.") + (:method ((backend backend) (place t)) + "The default" + (internal-restore-object backend (get-next-reader backend place) place))) + +(defgeneric internal-restore-object (backend type place)) + + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/readme ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/readme Mon Feb 18 09:40:18 2008 @@ -0,0 +1,62 @@ +README for Package CL-STORE. +Author: Sean Ross +Homepage: http://www.common-lisp.net/project/cl-store/ +Version: 0.6 + +0. About. + CL-STORE is an portable serialization package which + should give you the ability to store all common-lisp + data types (well not all yet) into streams. + See the cl-store manual (docs/cl-store.texi) for more in depth information. + + !!! NOTE: The cl-store-xml backend is deprecated. + +1. Usage + The main entry points are + - [Method] cl-store:store (obj place &optional (backend *default-backend*)) + => obj + Where place is a path designator or stream and + backend is one of the registered backends. + + - [Method] cl-store:restore (place &optional (backend *default-backend*)) + => restored-objects + Where place and backend is as above. + + - cl-store:restore is setfable, which I think makes + for a great serialized hit counter. + eg. (incf (restore place)) + + NOTE. + All errors signalled within store and restore can + be handled by catching store-error and restore-error respectively. + +2. Optimizing. + + While cl-store is generally quickish it still has a tendency to + do a lot of consing. Thanks to profilers this has been pinned down + to the rehashing of the hash-tables which track object circularities. + From 0.4.0 cl-store has three new variables *store-hash-size*, *restore-hash-size* + and *check-for-circs*, proper usage of these new variables can greatly reduce + the consing (and time taken) when storing and restoring large objects. + + - *store-hash-size* and *restore-hash-size + At the beginning of storing and restoring an eq hash-table is created with a + default size of 50 to track objects which have been (re)stored. On large objects however + the rehashing of these hash-tables imposes a severe drain on performance. + By binding these two variables to appropriately large values + about (100010 for a hash-table with 100000 int->string mappings) you + can obtain a decent performance improvement. This may require a bit + of fiddling to find the best tradeoff between rehashing and creating + a large hash-table. + + - *check-for-circs* + Binding this variable to nil when storing or restoring + an object inhibits all checks for circularities which gives a + severe boost to performance. The downside of this is that no + restored objects will be eq and attempting to store circular objects + will hang. The speed improvements are definitely worth it if you + know that there will be no circularities or shared references in + your data (eg spam-filter hash-tables). + +Enjoy + Sean. Added: trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store-xml) + + +(defstore-xml (obj structure-object stream) + (with-tag ("STRUCTURE-OBJECT" stream) + (princ-and-store "CLASS" (type-of obj) stream) + (xml-dump-type-object obj stream))) + + +(defrestore-xml (structure-object place) + (restore-xml-type-object place)) + + +(defstore-xml (obj single-float stream) + (with-tag ("SINGLE-FLOAT" stream) + (princ-and-store "BITS" (sb-kernel::single-float-bits obj) + stream))) + +(defrestore-xml (single-float stream) + (sb-kernel::make-single-float + (restore-first (get-child "BITS" stream)))) + +(defstore-xml (obj double-float stream) + (with-tag ("DOUBLE-FLOAT" stream) + (princ-and-store "HIGH-BITS" (sb-kernel::double-float-high-bits obj) + stream) + (princ-and-store "LOW-BITS" (sb-kernel::double-float-low-bits obj) + stream))) + +(defrestore-xml (double-float stream) + (sb-kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream)) + (restore-first (get-child "LOW-BITS" stream)))) + + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,162 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store) + +; special floats +(defun create-float-values (value &rest codes) + "Returns a alist of special float to float code mappings." + (sb-int:with-float-traps-masked (:overflow :invalid) + (let ((neg-inf (expt value 3))) + (mapcar 'cons + (list (expt (abs value) 2) + neg-inf + (/ neg-inf neg-inf)) + codes)))) + +;; Custom structure storing + +(defstore-cl-store (obj structure-object stream) + (output-type-code +structure-object-code+ stream) + (store-type-object obj stream)) + +(defrestore-cl-store (structure-object stream) + (restore-type-object stream)) + + +;; Structure definition storing +(defun get-layout (obj) + (slot-value obj 'sb-pcl::wrapper)) + +(defun get-info (obj) + (declare (type sb-kernel:layout obj)) + (slot-value obj 'sb-int:info)) + +(defun dd-name (dd) + (slot-value dd 'sb-kernel::name)) + +(defvar *sbcl-struct-inherits* + `(,(get-layout (find-class t)) + ,@(when-let (class (find-class 'sb-kernel:instance nil)) + (list (get-layout class))) + ,(get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type sb-kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'sb-kernel::inherits) + 'list) + *sbcl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring +(defun sbcl-struct-defs (info) + (append (sb-kernel::constructor-definitions info) + (sb-kernel::class-method-definitions info))) + +(defun create-make-foo (dd) + (declare (optimize speed)) + (funcall (compile nil `(lambda () ,@(sbcl-struct-defs dd)))) + (find-class (dd-name dd))) + +;;; with apologies to christophe rhodes ... +;; takes a source location as a third argument. +(eval-when (:compile-toplevel) + (defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end)))))))) + +;; From 0.9.6.25 sb-kernel::%defstruct +;; takes a source location as a third argument. +(eval-when (:compile-toplevel) + (labels ((make-version (string) + (map-into (make-list 4 :initial-element 0) + #'(lambda (part) + (parse-integer part :junk-allowed t)) + (split string nil '(#\.)))) + (version>= (v1 v2) + (loop for x in (make-version v1) + for y in (make-version v2) + when (> x y) :do (return t) + when (> y x) :do (return nil) + finally (return t)))) + (when (version>= (lisp-implementation-version) + "0.9.6.25") + (pushnew :defstruct-has-source-location *features*)))) + +(defun sb-kernel-defstruct (dd supers source) + (declare (ignorable source)) + #+defstruct-has-source-location + (sb-kernel::%defstruct dd supers source) + #-defstruct-has-source-location + (sb-kernel::%defstruct dd supers)) + +(defun sbcl-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (sb-kernel-defstruct dd supers nil) + ;; compiler stuff + (sb-kernel::%compiler-defstruct dd supers) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (sbcl-define-structure dd (if supers + (coerce (append *sbcl-struct-inherits* + supers) + 'vector) + (coerce *sbcl-struct-inherits* 'vector))))) + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/sysdef.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/sysdef.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,13 @@ +(in-package :sysdef-user) + +(define-system :CL-STORE (cl-store-system ) + (:author "Sean Ross <sross@common-lisp.net>") + (:version 0 8 3) + (:documentation "Portable CL Package to serialize data") + (:licence "MIT") + (:components "package" "utils" + #+(or abcl (and clisp (not mop))) "mop" + "backends" "plumbing" "circularities" "default-backend" + ("custom" non-required-file)) + (:pathname #.(directory-namestring *compile-file-truename*)) + (:needs (sysdef::test-action :rt))) Added: trunk/thirdparty/cl-store_0.8.4/tests.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/tests.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,716 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. +(defpackage :cl-store-tests + (:use :cl :regression-test :cl-store)) + +(in-package :cl-store-tests) + +(rem-all-tests) +(defvar *test-file* "filetest.cls") + +(defun restores (val) + (store val *test-file*) + (let ((restored (restore *test-file*))) + (or (and (numberp val) (= val restored)) + (and (stringp val) (string= val restored)) + (and (characterp val) (char= val restored)) + (eql val restored) + (equal val restored) + (equalp val restored)))) + +(defmacro deftestit (name val) + `(deftest ,name (restores ,val) t)) + +;; integers +(deftestit integer.1 1) +(deftestit integer.2 0) +(deftestit integer.3 23423333333333333333333333423102334) +(deftestit integer.4 -2322993) +(deftestit integer.5 most-positive-fixnum) +(deftestit integer.6 most-negative-fixnum) +(deftestit integer.7 #x100000000) + +;; ratios +(deftestit ratio.1 1/2) +(deftestit ratio.2 234232/23434) +(deftestit ratio.3 -12/2) +(deftestit ratio.4 -6/11) +(deftestit ratio.5 23222/13) + +;; complex numbers +(deftestit complex.1 #C(0 1)) +(deftestit complex.2 #C(0.0 1.0)) +(deftestit complex.3 #C(32 -23455)) +(deftestit complex.4 #C(-222.32 2322.21)) +(deftestit complex.5 #C(-111 -1123)) +(deftestit complex.6 #C(-11.2 -34.5)) + + +;; short floats + +;; single-float +(deftestit single-float.1 3244.32) +(deftestit single-float.2 0.12) +(deftestit single-float.3 -233.001) +(deftestit single-float.4 most-positive-single-float) +(deftestit single-float.5 most-negative-single-float) + +;; double-float +(deftestit double-float.1 2343.3d0) +(deftestit double-float.2 -1211111.3343d0) +(deftestit double-float.3 99999999999123456789012345678222222222222290.0987654321d0) +(deftestit double-float.4 -99999999999123456789012345678222222222222290.0987654321d0) +(deftestit double-float.5 most-positive-double-float) +(deftestit double-float.6 most-negative-double-float) + +;; long floats + +;; infinite floats +#+(or sbcl cmu lispworks allegro) +(progn + #+sbcl (sb-int:set-floating-point-modes :traps nil) + #+cmu (ext:set-floating-point-modes :traps nil) + (deftestit infinite-float.1 (expt most-positive-single-float 3)) + (deftestit infinite-float.2 (expt most-positive-double-float 3)) + (deftestit infinite-float.3 (expt most-negative-single-float 3)) + (deftestit infinite-float.4 (expt most-negative-double-float 3)) + (deftestit infinite-float.5 (/ (expt most-positive-single-float 3) + (expt most-positive-single-float 3))) + (deftestit infinite-float.6 (/ (expt most-positive-double-float 3) + (expt most-positive-double-float 3)))) + + +;; characters +(deftestit char.1 #\Space) +(deftestit char.2 #\f ) +(deftestit char.3 #\Rubout) +(deftestit char.4 (code-char 255)) + + +;; various strings +(deftestit string.1 "foobar") +(deftestit string.2 "how are you") +(deftestit string.3 "foo +bar") + +(deftestit string.4 + (make-array 10 :initial-element #\f :element-type 'character + :fill-pointer 3)) + +#+(or (and sbcl sb-unicode) lispworks clisp acl) +(progn + (deftestit unicode.1 (map #-lispworks 'string + #+lispworks 'lw:text-string + #'code-char (list #X20AC #X3BB))) + (deftestit unicode.2 (intern (map #-lispworks 'string + #+lispworks 'lw:text-string + #'code-char (list #X20AC #X3BB)) + :cl-store-tests))) + +;; vectors +(deftestit vector.1 #(1 2 3 4)) + + +(deftestit vector.2 (make-array 5 :element-type 'fixnum + :initial-contents (list 1 2 3 4 5))) + +(deftestit vector.3 + (make-array 5 + :element-type 'fixnum + :fill-pointer 2 + :initial-contents (list 1 2 3 4 5))) + + +(deftestit vector.4 #*101101101110) +(deftestit vector.5 #*) +(deftestit vector.6 #()) + + +;; (array octect (*)) + +(deftestit vector.octet.1 (make-array 10 :element-type '(unsigned-byte 8))) + + +;; arrays +(deftestit array.1 + (make-array '(2 2) :initial-contents '((1 2) (3 4)))) + +(deftestit array.2 + (make-array '(2 2) :initial-contents '((1 1) (1 1)))) + +(deftestit array.3 + (make-array '(2 2) :element-type '(mod 10) :initial-element 3)) + +(deftestit array.4 + (make-array '(2 3 5) + :initial-contents + '(((1 2 #\f 5 12.0) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1)) + ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1) + (#\Newline 1 7 #\4 #\0))))) + +(deftestit array.5 + (let* ((a1 (make-array 5)) + (a2 (make-array 4 :displaced-to a1 + :displaced-index-offset 1)) + (a3 (make-array 2 :displaced-to a2 + :displaced-index-offset 2))) + a3)) + + + + +;; symbols + +(deftestit symbol.1 t) +(deftestit symbol.2 nil) +(deftestit symbol.3 :foo) +(deftestit symbol.4 'cl-store-tests::foo) +(deftestit symbol.5 'make-hash-table) +(deftestit symbol.6 '|foo bar|) +(deftestit symbol.7 'foo\ bar\ baz) + +(deftest gensym.1 (progn + (store (gensym "Foobar") *test-file*) + (let ((new (restore *test-file*))) + (list (symbol-package new) + (mismatch "Foobar" (symbol-name new))))) + (nil 6)) + +; This failed in cl-store < 0.5.5 +(deftest gensym.2 (let ((x (gensym))) + (store (list x x) *test-file*) + (let ((new (restore *test-file*))) + (eql (car new) (cadr new)))) + t) + + +;; cons + +(deftestit cons.1 '(1 2 3)) +(deftestit cons.2 '((1 2 3))) +(deftestit cons.3 '(#\Space 1 1/2 1.3 #(1 2 3))) + +(deftestit cons.4 '(1 . 2)) +(deftestit cons.5 '(t . nil)) +(deftestit cons.6 '(1 2 3 . 5)) +(deftest cons.7 (let ((list (cons nil nil))) + (setf (car list) list) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (eq ret (car ret)))) + t) + + +;; hash tables +; for some reason (make-hash-table) is not equalp +; to (make-hash-table) with ecl. + +#-ecl +(deftestit hash.1 (make-hash-table)) + +#-ecl +(defvar *hash* (let ((in (make-hash-table :test #'equal + :rehash-threshold 0.4 :size 20 + :rehash-size 40))) + (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x)) + in)) +#-ecl +(deftestit hash.2 *hash*) + + +;; packages +(deftestit package.1 (find-package :cl-store)) + +(defpackage foo + (:nicknames foobar) + (:use :cl) + (:shadow cl:format) + (:export bar)) + +(defun package-restores () + (let (( *nuke-existing-packages* t)) + (store (find-package :foo) *test-file*) + (delete-package :foo) + (restore *test-file*) + (list (package-name (find-package :foo)) + (mapcar #'package-name (package-use-list :foo)) + (package-nicknames :foo) + (equalp (remove-duplicates (package-shadowing-symbols :foo)) + (list (find-symbol "FORMAT" "FOO"))) + (equalp (cl-store::external-symbols (find-package :foo)) + (make-array 1 :initial-element (find-symbol "BAR" "FOO")))))) + + +; unfortunately it's difficult to portably test the internal symbols +; in a package so we just assume that it's OK. +(deftest package.2 + (package-restores) + ("FOO" ("COMMON-LISP") ("FOOBAR") t t)) + +;; objects +(defclass foo () + ((x :accessor get-x :initarg :x))) + +(defclass bar (foo) + ((y :accessor get-y :initform nil :initarg :y))) + +(defclass quux () + (a)) + +(defclass baz (quux) + ((z :accessor get-z :initarg :z :allocation :class))) + + + +(deftest standard-object.1 + (let ((val (store (make-instance 'foo :x 3) *test-file*))) + (= (get-x val) (get-x (restore *test-file*)))) + t) + +(deftest standard-object.2 + (let ((val (store (make-instance 'bar + :x (list 1 "foo" 1.0) + :y (vector 1 2 3 4)) + *test-file*))) + (let ((ret (restore *test-file*))) + (and (equalp (get-x val) (get-x ret)) + (equalp (get-y val) (get-y ret))))) + t) + +(deftest standard-object.3 + (let ((*store-class-slots* nil) + (val (make-instance 'baz :z 9))) + (store val *test-file*) + (make-instance 'baz :z 2) + (= (get-z (restore *test-file*)) + 2)) + t) + +(deftest standard-object.4 + (let ((*store-class-slots* t) + (val (make-instance 'baz :z 9))) + (store val *test-file*) + (make-instance 'baz :z 2) + (let ((ret (restore *test-file*))) + (= (get-z ret ) + 9))) + t) + +;; classes +(deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) + (restore *test-file*) + t) + t) + +(deftest standard-class.2 (progn (store (find-class 'bar) *test-file*) + (restore *test-file*) + t) + t) + +(deftest standard-class.3 (progn (store (find-class 'baz) *test-file*) + (restore *test-file*) + t) + t) + + + +;; conditions +(deftest condition.1 + (handler-case (/ 1 0) + (division-by-zero (c) + (store c *test-file*) + (typep (restore *test-file*) 'division-by-zero))) + t) + +(deftest condition.2 + (handler-case (car (read-from-string "3")) + ;; allegro pre 7.0 signalled a simple-error here + ((or type-error simple-error) (c) + (store c *test-file*) + (typep (restore *test-file*) + '(or type-error simple-error)))) + t) + +;; structure-object + +(defstruct a + a b c) + +(defstruct (b (:include a)) + d e f) + +#+(or sbcl cmu lispworks openmcl) +(deftestit structure-object.1 (make-a :a 1 :b 2 :c 3)) +#+(or sbcl cmu lispworks openmcl) +(deftestit structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6)) +#+(or sbcl cmu lispworks openmcl) +(deftestit structure-object.3 (make-b :a 1 :b (make-a :a 1 :b 3 :c 2) + :c #\Space :d #(1 2 3) :e (list 1 2 3) + :f (make-hash-table))) + +;; setf test +(deftestit setf.1 (setf (restore *test-file*) 0)) +(deftestit setf.2 (incf (restore *test-file*))) +(deftestit setf.3 (decf (restore *test-file*) 2)) + +(deftestit pathname.1 #P"/home/foo") +(deftestit pathname.2 (make-pathname :name "foo")) +(deftestit pathname.3 (make-pathname :name "foo" :type "bar")) + + +; built-in classes +(deftestit built-in.1 (find-class 'hash-table)) +(deftestit built-in.2 (find-class 'integer)) + + +;; find-backend tests +(deftest find-backend.1 + (and (find-backend 'cl-store) t) + t) + +(deftest find-backend.2 + (find-backend (gensym)) + nil) + +(deftest find-backend.3 + (handler-case (find-backend (gensym) t) + (error (c) (and c t)) + (:no-error (val) (and val nil))) + t) + + + +;; circular objects +(defvar circ1 (let ((x (list 1 2 3 4))) + (setf (cdr (last x)) x))) +(deftest circ.1 (progn (store circ1 *test-file*) + (let ((x (restore *test-file*))) + (eql (cddddr x) x))) + t) + +(defvar circ2 (let ((x (list 2 3 4 4 5))) + (setf (second x) x))) +(deftest circ.2 (progn (store circ2 *test-file*) + (let ((x (restore *test-file*))) + (eql (second x) x))) + t) + + + +(defvar circ3 (let ((x (list (list 1 2 3 4 ) + (list 5 6 7 8) + 9))) + (setf (second x) (car x)) + (setf (cdr (last x)) x) + x)) + +(deftest circ.3 (progn (store circ3 *test-file*) + (let ((x (restore *test-file*))) + (and (eql (second x) (car x)) + (eql (cdddr x) x)))) + t) + + +(defvar circ4 (let ((x (make-hash-table))) + (setf (gethash 'first x) (make-hash-table)) + (setf (gethash 'second x) (gethash 'first x)) + (setf (gethash 'inner (gethash 'first x)) x) + x)) + +(deftest circ.4 (progn (store circ4 *test-file*) + (let ((x (restore *test-file*))) + (and (eql (gethash 'first x) + (gethash 'second x)) + (eql x + (gethash 'inner + (gethash 'first x)))))) + t) + +(deftest circ.5 (let ((circ5 (make-instance 'bar))) + (setf (get-y circ5) circ5) + (store circ5 *test-file*) + (let ((x (restore *test-file*))) + (eql x (get-y x)))) + t) + + +(defvar circ6 (let ((y (make-array '(2 2 2) + :initial-contents '((("foo" "bar") + ("me" "you")) + ((5 6) (7 8)))))) + (setf (aref y 1 1 1) y) + (setf (aref y 0 0 0) (aref y 1 1 1)) + y)) + + +(deftest circ.6 (progn (store circ6 *test-file*) + (let ((x (restore *test-file*))) + (and (eql (aref x 1 1 1) x) + (eql (aref x 0 0 0) (aref x 1 1 1))))) + t) + + + +(defvar circ7 (let ((x (make-a))) + (setf (a-a x) x))) + +#+(or sbcl cmu lispworks) +(deftest circ.7 (progn (store circ7 *test-file*) + (let ((x (restore *test-file*))) + (eql (a-a x) x))) + t) + +(defvar circ.8 (let ((x "foo")) + (make-pathname :name x :type x))) + + +;; clisp apparently creates a copy of the strings in a pathname +;; so a test for eqness is pointless. +#-clisp +(deftest circ.8 (progn (store circ.8 *test-file*) + (let ((x (restore *test-file*))) + (eql (pathname-name x) + (pathname-type x)))) + t) + + +(deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2))) + (setf (aref val 3) val) + (setf (aref val 4) (aref val 0)) + (store val *test-file*) + (let ((rest (restore *test-file*))) + (and (eql rest (aref rest 3)) + (eql (aref rest 4) (aref rest 0))))) + t) + +(deftest circ.10 (let* ((a1 (make-array 5)) + (a2 (make-array 4 :displaced-to a1 + :displaced-index-offset 1)) + (a3 (make-array 2 :displaced-to a2 + :displaced-index-offset 2))) + (setf (aref a3 1) a3) + (store a3 *test-file*) + (let ((ret (restore *test-file*))) + (eql a3 (aref a3 1)))) + t) + +(defvar circ.11 (let ((x (make-hash-table))) + (setf (gethash x x) x) + x)) + +(deftest circ.11 (progn (store circ.11 *test-file*) + (let ((val (restore *test-file*))) + (eql val (gethash val val)))) + t) + +(deftest circ.12 (let ((x (vector 1 2 "foo" 4 5))) + (setf (aref x 0) x) + (setf (aref x 1) (aref x 2)) + (store x *test-file*) + (let ((ret (restore *test-file*))) + (and (eql (aref ret 0) ret) + (eql (aref ret 1) (aref ret 2))))) + t) + + +(defclass foo.1 () + ((a :accessor foo1-a))) + +;; a test from Robert Sedgwick which crashed in earlier +;; versions (pre 0.2) +(deftest circ.13 (let ((foo (make-instance 'foo.1)) + (bar (make-instance 'foo.1))) + (setf (foo1-a foo) bar) + (setf (foo1-a bar) foo) + (store (list foo) *test-file*) + (let ((ret (car (restore *test-file*)))) + (and (eql ret (foo1-a (foo1-a ret))) + (eql (foo1-a ret) + (foo1-a (foo1-a (foo1-a ret))))))) + t) + +#-abcl +(deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (cddddr ret)) + (eq (fourth ret) ret)))) + t) + + + + +#-abcl +(deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (cddddr ret)) + (eq (fourth ret) + (car (fourth ret)))))) + t) + + + +;; this had me confused for a while since what was +;; restored #1=(1 (#1#) #1#) looks nothing like this list, +;; but it turns out that it is correct +#-abcl +(deftest circ.16 (let ((list '#1=(1 #2=(#1#) . #2#))) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (and (eq ret (caadr ret)) + (eq ret (third ret))))) + t) + +;; large circular lists +#-abcl +(deftest large.1 (let ((list (make-list 100000))) + (setf (cdr (last list)) list) + (store list *test-file*) + (let ((ret (restore *test-file*))) + (eq (nthcdr 100000 ret) ret))) + t) + +;; large dotted lists +#-abcl +(deftestit large.2 (let ((list (make-list 100000))) + (setf (cdr (last list)) 'foo) + list)) + + + +;; custom storing +(defclass random-obj () ((size :accessor size :initarg :size))) + +(defparameter *random-obj-code* (register-code 100 'random-obj)) + +(defstore-cl-store (obj random-obj buff) + (output-type-code *random-obj-code* buff) + (store-object (size obj) buff)) + +(defrestore-cl-store (random-obj buff) + (random (restore-object buff))) + + +(deftest custom.1 + (progn (store (make-instance 'random-obj :size 5) *test-file* ) + (typep (restore *test-file*) '(integer 0 4))) + t) + + +;; These tests are quite incorrect as there is no universal method +;; test for function equality when they are not eq. +;; While this will work for functions restored based on name +;; it will most definitely not work for closures. +;; So we just do limited tests on behaviour +(deftestit function.1 #'car) + + +(deftest function.2 + (progn (store #'cl-store::mkstr *test-file*) + (let ((fn (restore *test-file*))) + (every (lambda (args) + (string= (apply fn args) (apply #'cl-store::mkstr args))) + '(("foobar" "baz") + ("a" "b" "c") + ("1 2" "ab " "f oO"))))) + t) + +;; Closures are clisp only. +#+clisp +(deftest function.3 + (progn (store (list #'(lambda (x y) (funcall x (1+ y))) + #'(lambda (x) (expt x 3))) + *test-file*) + (destructuring-bind (fn-a fn-b) (restore *test-file*) + (funcall fn-a fn-b 3))) + 64) + +(let ((x 1)) + (defun foo () + (incf x)) + (defun bar () + (decf x))) + +;; While this works on all Lisps only CLISP is actually creating +;; a fresh function on the restore. +#+clisp +(deftest function.4 + (progn (store (list #'foo #'bar) *test-file*) + (destructuring-bind (fn-a fn-b) (restore *test-file*) + (values (funcall fn-a) + (funcall fn-a) + (funcall fn-b)))) + 2 3 2) + +(deftestit gfunction.1 #'cl-store:restore) +(deftestit gfunction.2 #'cl-store:store) +#-clisp +(deftestit gfunction.3 #'(setf get-y)) + + +(deftest nocirc.1 + (let* ((string "FOO") + (list `(,string . ,string)) + (*check-for-circs* nil)) + (store list *test-file*) + (let ((res (restore *test-file*))) + (and (not (eql (car res) (cdr res))) + (string= (car res) (cdr res))))) + t) + + +(defstruct st.bar x) +(defstruct (st.foo (:conc-name f-) + (:constructor fooo (z y x)) + (:copier cp-foo) + (:include st.bar) + (:predicate is-foo) + (:print-function (lambda (obj st dep) + (declare (ignore dep)) + (print-unreadable-object (obj st :type t) + (format st "~A" (f-x obj)))))) + (y 0 :type integer) (z nil :type simple-string)) + + +#+(or sbcl cmu) +(deftest struct-class.1 + (let* ((obj (fooo "Z" 2 3)) + (string (format nil "~A" obj))) + (let ((*nuke-existing-classes* t)) + (store (find-class 'st.foo) *test-file*) + (fmakunbound 'cp-foo) + (fmakunbound 'is-foo) + (fmakunbound 'fooo) + (fmakunbound 'f-x) + (fmakunbound 'f-y) + (fmakunbound 'f-z) + (restore *test-file*) + (let* ((new-obj (cp-foo (fooo "Z" 2 3))) + (new-string (format nil "~A" new-obj))) + (list (is-foo new-obj) (equalp obj new-obj) + (string= new-string string) + (f-x new-obj) (f-y new-obj) (f-z new-obj))))) + (t t t 3 2 "Z")) + +(deftest serialization-unit.1 + (with-serialization-unit () + (with-open-file (outs *test-file* :element-type '(unsigned-byte 8) + :if-exists :supersede :direction :output) + (dotimes (x 100) + (cl-store:store x outs))) + (with-open-file (outs *test-file* :element-type '(unsigned-byte 8) + :if-exists :supersede) + (loop :repeat 100 :collect (cl-store:restore outs)))) + #.(loop :for x :below 100 :collect x)) + +(defun run-tests (backend) + (with-backend backend + (regression-test:do-tests)) + (when (probe-file *test-file*) + (ignore-errors (delete-file *test-file*)))) + + +(do-tests) +;; EOF + Added: trunk/thirdparty/cl-store_0.8.4/utils.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/utils.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,165 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; Miscellaneous utilities used throughout the package. +(in-package :cl-store) + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(defmacro with-gensyms (names &body body) + `(let ,(mapcar #'(lambda (x) `(,x (gensym))) names) + ,@body)) + +(defgeneric serializable-slots (object) + (declare (optimize speed)) + (:documentation + "Return a list of slot-definitions to serialize. The default + is to call serializable-slots-using-class with the object + and the objects class") + (:method ((object standard-object)) + (serializable-slots-using-class object (class-of object))) +#+(or sbcl cmu openmcl) + (:method ((object structure-object)) + (serializable-slots-using-class object (class-of object))) + (:method ((object condition)) + (serializable-slots-using-class object (class-of object)))) + +; unfortunately the metaclass of conditions in sbcl and cmu +; are not standard-class + +(defgeneric serializable-slots-using-class (object class) + (declare (optimize speed)) + (:documentation "Return a list of slot-definitions to serialize. + The default calls compute slots with class") + (:method ((object t) (class standard-class)) + (class-slots class)) +#+(or sbcl cmu openmcl) + (:method ((object t) (class structure-class)) + (class-slots class)) +#+sbcl + (:method ((object t) (class sb-pcl::condition-class)) + (class-slots class)) +#+cmu + (:method ((object t) (class pcl::condition-class)) + (class-slots class))) + + +; Generify get-slot-details for customization (from Thomas Stenhaug) +(defgeneric get-slot-details (slot-definition) + (declare (optimize speed)) + (:documentation + "Return a list of slot details which can be used + as an argument to ensure-class") + (:method ((slot-definition #+(or ecl abcl (and clisp (not mop))) t + #-(or ecl abcl (and clisp (not mop))) slot-definition)) + (list :name (slot-definition-name slot-definition) + :allocation (slot-definition-allocation slot-definition) + :initargs (slot-definition-initargs slot-definition) + ;; :initform. dont use initform until we can + ;; serialize functions + :readers (slot-definition-readers slot-definition) + :type (slot-definition-type slot-definition) + :writers (slot-definition-writers slot-definition))) + #+openmcl + (:method ((slot-definition ccl::structure-slot-definition)) + (list :name (slot-definition-name slot-definition) + :allocation (slot-definition-allocation slot-definition) + :initargs (slot-definition-initargs slot-definition) + ;; :initform. dont use initform until we can + ;; serialize functions + ;; :readers (slot-definition-readers slot-definition) + :type (slot-definition-type slot-definition) + ;; :writers (slot-definition-writers slot-definition) + ))) + +(defmacro when-let ((var test) &body body) + `(let ((,var ,test)) + (when ,var + ,@body))) + + +;; because clisp doesn't have the class single-float or double-float. +(defun float-type (float) + (etypecase float + (single-float 0) + (double-float 1) + (short-float 2) + (long-float 3))) + +(defun get-float-type (num) + (ecase num + (0 1.0) + (1 1.0d0) + (2 1.0s0) + (3 1.0l0))) + +(deftype ub32 () + `(unsigned-byte 32)) + +(deftype sb32 () + `(signed-byte 32)) + +(deftype array-size () + "The maximum size of a vector" + `(integer 0 , array-dimension-limit)) + +(deftype array-tot-size () + "The maximum total size of an array" + `(integer 0 , array-total-size-limit)) + +(defun store-32-bit (obj stream) + "Write OBJ down STREAM as a 32 bit integer." + (declare (optimize speed (debug 0) (safety 0)) + (type ub32 obj)) + (write-byte (ldb (byte 8 0) obj) stream) + (write-byte (ldb (byte 8 8) obj) stream) + (write-byte (ldb (byte 8 16) obj) stream) + (write-byte (+ 0 (ldb (byte 8 24) obj)) stream)) + +(defmacro make-ub32 (a b c d) + `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d))) + +(defun read-32-bit (buf &optional (signed t)) + "Read a signed or unsigned byte off STREAM." + (declare (optimize speed (debug 0) (safety 0))) + (let ((byte1 (read-byte buf)) + (byte2 (read-byte buf)) + (byte3 (read-byte buf)) + (byte4 (read-byte buf))) + (declare (type (mod 256) byte1 byte2 byte3 byte4)) + (let ((ret (make-ub32 byte4 byte3 byte2 byte1))) + (if (and signed (> byte1 127)) + (logior (ash -1 32) ret) + ret)))) + +(defun kwd (name) + (values (intern (string-upcase name) :keyword))) + +(defun mkstr (&rest args) + (with-output-to-string (s) + (dolist (x args) + (format s "~@:(~A~)" x)))) + +(defun symbolicate (&rest syms) + "Concatenate all symbol names into one big symbol" + (values (intern (apply #'mkstr syms)))) + +;; Taken straight from swank.lisp --- public domain +;; and then slightly modified +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Modified to work on non proper lists." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return (values (/ n 2) list))) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,486 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK +;; ITS PRESENCE IS FOR POSTERITY ONLY +(in-package :cl-store-xml) + + +(defbackend xml :stream-type 'character :extends (resolving-backend)) + +;; The xml backend does not use any type codes +;; we figure it out when we read the tag of each object +(defvar *xml-mapping* (make-hash-table :test #'equal)) +(defun add-xml-mapping (name) + (setf (gethash name *xml-mapping*) + (intern name :cl-store-xml))) + +(add-xml-mapping "REFERRER") +(add-xml-mapping "INTEGER") +(add-xml-mapping "FLOAT") +(add-xml-mapping "SIMPLE-STRING") +(add-xml-mapping "SYMBOL") +(add-xml-mapping "CONS") +(add-xml-mapping "RATIO") +(add-xml-mapping "CHARACTER") +(add-xml-mapping "COMPLEX") +(add-xml-mapping "PATHNAME") +(add-xml-mapping "FUNCTION") +(add-xml-mapping "GENERIC-FUNCTION") + +(defmethod get-next-reader ((backend xml) (place list)) + (or (gethash (car place) *xml-mapping*) + (error "Unknown tag ~A" (car place)))) + +(defun princ-xml (tag value stream) + (format stream "<~A>" tag) + (xmls:write-xml value stream) + (format stream "</~A>" tag)) + +(defun princ-and-store (tag obj stream) + (format stream "<~A>" tag) + (store-object obj stream) + (format stream "</~A>" tag)) + +(defmacro with-tag ((tag stream) &body body) + `(progn + (format ,stream "<~A>" ,tag) + ,@body + (format ,stream "</~A>" ,tag))) + +(defun first-child (elmt) + (first (xmls:node-children elmt))) + +(defun second-child (elmt) + (second (xmls:node-children elmt))) + +(defun get-child (name elmt &optional (errorp t)) + (or (assoc name (xmls:node-children elmt) :test #'equal) + (and errorp + (restore-error "No child called ~A in xml ~a" + (list name elmt))))) + +(defun get-attr (name elmt) + (cadr (assoc name (xmls:node-attrs elmt) :test #'equal))) + +(declaim (inline restore-first)) +(defun restore-first (place) + (restore-object (first-child place))) + +(defmethod store-referrer ((backend xml) (ref t) (stream t)) + (princ-xml "REFERRER" ref stream)) + +(defrestore-xml (referrer place) + (make-referrer :val (parse-integer (third place)))) + +(defmethod referrerp ((backend xml) (reader t)) + (eql reader 'referrer)) + +;; override backend restore to parse the incoming stream +(defmethod backend-restore ((backend xml) (place stream)) + (let ((*restore-counter* 0) + (*need-to-fix* nil) + (*print-circle* nil) + (*restored-values* (and *check-for-circs* + (make-hash-table :test #'eq :size *restore-hash-size*)))) + (multiple-value-prog1 + (backend-restore-object backend + (or (xmls:parse place) + (restore-error "Invalid xml"))) + (dolist (fn *need-to-fix*) + (force fn))))) + +;; integer +(defstore-xml (obj integer stream) + (princ-xml "INTEGER" obj stream)) + +(defrestore-xml (integer from) + (values (parse-integer (first-child from)))) + +;; floats +(defvar *special-floats* nil) ;; setup in custom-xml files + +;; FIXME: add support for *special-floats* +(defstore-xml (obj float stream) + (with-tag ("FLOAT" stream) (print obj stream))) + +(defrestore-xml (float from) + (cl-l10n:parse-number (first-child from))) + +#| +(defstore-xml (obj single-float stream) + (store-float "SINGLE-FLOAT" obj stream)) + +(defstore-xml (obj double-float stream) + (store-float "DOUBLE-FLOAT" obj stream)) + +(defun store-float (type obj stream) + (block body + (let (significand exponent sign) + (handler-bind ((simple-error + #'(lambda (err) + (declare (ignore err)) + (when-let (type (cdr (assoc obj *special-floats*))) + (output-float-type type stream) + (return-from body))))) + (multiple-value-setq (significand exponent sign) + (integer-decode-float obj)) + (with-tag (type stream) + (princ-and-store "SIGNIFICAND" significand stream) + (princ-and-store "RADIX"(float-radix obj) stream) + (princ-and-store "EXPONENT" exponent stream) + (princ-and-store "SIGN" sign stream)))))) +|# + +; FIXME: restore flaot + +;; ratio +(defstore-xml (obj ratio stream) + (with-tag ("RATIO" stream) + (princ-and-store "NUMERATOR" (numerator obj) stream) + (princ-and-store "DENOMINATOR" (denominator obj) stream))) + +(defrestore-xml (ratio from) + (/ (restore-first (get-child "NUMERATOR" from)) + (restore-first (get-child "DENOMINATOR" from)))) + +;; char +(defstore-xml (obj character stream) + (princ-and-store "CHARACTER" (char-code obj) stream)) + +(defrestore-xml (character from) + (code-char (restore-first from))) + + +;; complex +(defstore-xml (obj complex stream) + (with-tag ("COMPLEX" stream) + (princ-and-store "REALPART" (realpart obj) stream) + (princ-and-store "IMAGPART" (imagpart obj) stream))) + + +(defrestore-xml (complex from) + (complex (restore-first (get-child "REALPART" from)) + (restore-first (get-child "IMAGPART" from)))) + + +;; symbols +(defstore-xml (obj symbol stream) + (with-tag ("SYMBOL" stream) + (princ-and-store "NAME" (symbol-name obj) stream) + (cl-store::when-let (package (symbol-package obj)) + (princ-and-store "PACKAGE" (package-name package) stream)))) + +(defrestore-xml (symbol from) + (let ((name (restore-first (get-child "NAME" from))) + (package (when (get-child "PACKAGE" from nil) + (restore-first (get-child "PACKAGE" from))))) + (if package + (values (intern name package)) + (make-symbol name)))) + +;; lists +(defstore-xml (obj cons stream) + (with-tag ("CONS" stream) + (princ-and-store "CAR" (car obj) stream) + (princ-and-store "CDR" (cdr obj) stream))) + +(defrestore-xml (cons from) + (resolving-object (x (cons nil nil)) + (setting (car x) (restore-first (get-child "CAR" from))) + (setting (cdr x) (restore-first (get-child "CDR" from))))) + +;; simple string +(defstore-xml (obj simple-string stream) + (princ-xml "SIMPLE-STRING" obj stream)) + +(defrestore-xml (simple-string from) + (first-child from)) + + +;; pathnames +(defstore-xml (obj pathname stream) + (with-tag ("PATHNAME" stream) + (princ-and-store "DEVICE" (pathname-device obj) stream) + (princ-and-store "DIRECTORY" (pathname-directory obj) stream) + (princ-and-store "NAME" (pathname-name obj) stream) + (princ-and-store "TYPE" (pathname-type obj) stream) + (princ-and-store "VERSION" (pathname-version obj) stream))) + +(defrestore-xml (pathname place) + (make-pathname + :device (restore-first (get-child "DEVICE" place)) + :directory (restore-first (get-child "DIRECTORY" place)) + :name (restore-first (get-child "NAME" place)) + :type (restore-first (get-child "TYPE" place)) + :version (restore-first (get-child "VERSION" place)))) + + +; hash table +(defstore-xml (obj hash-table stream) + (with-tag ("HASH-TABLE" stream) + (princ-and-store "REHASH-SIZE" (hash-table-rehash-size obj) stream) + (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) stream) + (princ-and-store "SIZE" (hash-table-size obj) stream) + (princ-and-store "TEST" (hash-table-test obj) stream) + (with-tag ("ENTRIES" stream) + (loop for key being the hash-keys of obj + using (hash-value value) do + (with-tag ("ENTRY" stream) + (princ-and-store "KEY" key stream) + (princ-and-store "VALUE" value stream)))))) + +;; FIXME: restore hash tables + +;; objects and conditions + +(defun xml-dump-type-object (obj stream) + (let* ((all-slots (serializable-slots obj))) + (with-tag ("SLOTS" stream) + (dolist (slot all-slots) + (when (slot-boundp obj (slot-definition-name slot)) + (when (or *store-class-slots* + (eql (slot-definition-allocation slot) :instance)) + (with-tag ("SLOT" stream) + (let ((slot-name (slot-definition-name slot))) + (princ-and-store "NAME" slot-name stream) + (princ-and-store "VALUE" (slot-value obj slot-name) stream))))))))) + +(defstore-xml (obj standard-object stream) + (with-tag ("STANDARD-OBJECT" stream) + (princ-and-store "CLASS" (type-of obj) stream) + (xml-dump-type-object obj stream))) + +(defstore-xml (obj condition stream) + (with-tag ("CONDITION" stream) + (princ-and-store "CLASS" (type-of obj) stream) + (xml-dump-type-object obj stream))) + + +;; FIXME: restore objects + + + +;; classes + +;; FIXME : Write me + +;; built in classes +(defstore-xml (obj built-in-class stream) + (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream)) + +#-ecl ;; for some reason this doesn't work with ecl +(defmethod internal-store-object ((backend xml) (obj (eql (find-class 'hash-table))) stream) + (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream)) + +;; FIXME: restore built in classes + +;; arrays and vectors +;; FIXME : Write me + +;; packages +;; FIXME : Write me + +;; functions +(defstore-xml (obj function stream) + (princ-and-store "FUNCTION" (get-function-name obj) stream)) + +(defrestore-xml (function from) + (fdefinition (restore-first from))) + +;; generic functions +(defstore-xml (obj generic-function stream) + (if (generic-function-name obj) + (princ-and-store "GENERIC-FUNCTION" + (generic-function-name obj) stream) + (store-error "No generic function name for ~A." obj))) + +(defrestore-xml (generic-function from) + (fdefinition (restore-first from))) + +(setf *default-backend* (find-backend 'xml)) + +#| + +;; required methods and miscellaneous util functions + + +(defrestore-xml (hash-table place) + (let ((hash1 (make-hash-table + :rehash-size (restore-first (get-child "REHASH-SIZE" place)) + :rehash-threshold (restore-first + (get-child "REHASH-THRESHOLD" place)) + :size (restore-first (get-child "SIZE" place)) + :test (symbol-function (restore-first (get-child "TEST" place)))))) + (resolving-object (hash1 hash1) + (dolist (entry (xmls:node-children (get-child "ENTRIES" place))) + (let* ((key-place (first-child (first-child entry))) + (val-place (first-child (second-child entry)))) + (setting-hash (restore-object key-place) + (restore-object val-place))))) + hash1)) + + +(defun restore-xml-type-object (place) + (let* ((class (find-class (restore-first (get-child "CLASS" place)))) + (new-instance (allocate-instance class))) + (resolving-object new-instance + (dolist (slot (xmls:node-children (get-child "SLOTS" place))) + (let ((slot-name (restore-first (get-child "NAME" slot)))) + (setting (slot-value slot-name) + (restore-first (get-child "VALUE" slot)))))) + new-instance)) + +(defrestore-xml (standard-object place) + (restore-xml-type-object place)) + +(defrestore-xml (condition place) + (restore-xml-type-object place)) + +;; classes +(defun store-slot (slot stream) + (with-tag ("SLOT" stream) + (princ-and-store "NAME" (slot-definition-name slot) stream) + (princ-and-store "ALLOCATION" (slot-definition-allocation slot) stream) + (princ-and-store "TYPE" (slot-definition-type slot) stream) + (with-tag ("INITARGS" stream) + (dolist (x (slot-definition-initargs slot)) + (princ-and-store "INITARG" x stream))) + (with-tag ("READERS" stream) + (dolist (x (slot-definition-readers slot)) + (princ-and-store "READER" x stream))) + (with-tag ("WRITERS" stream) + (dolist (x (slot-definition-writers slot)) + (princ-and-store "WRITER" x stream))))) + +(defstore-xml (obj standard-class stream) + (with-tag ("STANDARD-CLASS" stream) + (princ-and-store "NAME" (class-name obj) stream) + (with-tag ("SUPERCLASSES" stream) + (loop for x in (class-direct-superclasses obj) do + (unless (eql x (find-class 'standard-object)) + (princ-and-store "SUPERCLASS" + (if *store-class-superclasses* + x + (class-name x)) + stream)))) + (with-tag ("SLOTS" stream) + (dolist (x (class-direct-slots obj)) + (store-slot x stream))) + (princ-and-store "METACLASS" (type-of obj) stream))) + + + +(defun xml-add-class (name slots superclasses metaclass) + (ensure-class name :direct-slots slots + :direct-superclasses superclasses + :metaclass metaclass) + #+clisp(add-methods-for-class name slots)) + +(defun get-values (values) + (loop for value in (xmls:node-children values) + collect (restore-first value))) + +(defun get-slots (slots) + (loop for slot in (xmls:node-children slots) + collect (list :name (restore-first (get-child "NAME" slot)) + :allocation (restore-first (get-child "ALLOCATION" slot)) + :type (restore-first (get-child "TYPE" slot)) + :initargs (get-values (get-child "INITARGS" slot)) + :readers (get-values (get-child "READERS" slot)) + :writers (get-values (get-child "WRITERS" slot))))) + +(defun get-superclasses (superclasses) + (loop for superclass in (xmls:node-children superclasses) + collect (restore-first superclass))) + +(defrestore-xml (standard-class place) + (let* ((name (restore-first (get-child "NAME" place))) + (superclasses (get-superclasses (get-child "SUPERCLASSES" place))) + (slots (get-slots (get-child "SLOTS" place))) + (metaclass (restore-first (get-child "METACLASS" place)))) + (cond (*nuke-existing-classes* + (xml-add-class name slots superclasses metaclass)) + (t (aif (find-class name nil) + it + (xml-add-class name slots superclasses metaclass)))))) + +;; built-in-classes +(defstore-xml (obj built-in-class stream) + (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream)) + +(defrestore-xml (built-in-class place) + (find-class (restore-first place))) + +;; I don't know if this really qualifies as a built-in-class but it +;; does make things a bit easier +(defmethod internal-store-object ((obj (eql (find-class 'hash-table))) stream + (backend xml-backend)) + (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream)) + + +;; Arrays and vectors +(defstore-xml (obj array stream) + (xml-dump-array obj stream)) + +(defun xml-dump-array (obj stream) + (with-tag ("ARRAY" stream) + (princ-and-store "DIMENSIONS" (array-dimensions obj) stream) + (if (and (= (array-rank obj) 1) + (array-has-fill-pointer-p obj)) + (princ-and-store "FILL-POINTER" (fill-pointer obj) stream) + (princ-and-store "FILL-POINTER" nil stream)) + (princ-and-store "ELEMENT-TYPE" (array-element-type obj) stream) + (multiple-value-bind (to offset) (array-displacement obj) + (princ-and-store "DISPLACED-TO" to stream) + (princ-and-store "DISPLACED-OFFSET" offset stream)) + (princ-and-store "ADJUSTABLE" (adjustable-array-p obj) stream) + (with-tag ("VALUES" stream) + (loop for x from 0 to (1- (array-total-size obj)) do + (princ-and-store "VALUE" (row-major-aref obj x) stream))))) + +(defrestore-xml (array place) + (let* ((dimensions (restore-first (get-child "DIMENSIONS" place))) + (fill-pointer (restore-first (get-child "FILL-POINTER" place))) + (element-type (restore-first (get-child "ELEMENT-TYPE" place))) + (displaced-to (restore-first (get-child "DISPLACED-TO" place))) + (displaced-offset (restore-first (get-child "DISPLACED-OFFSET" + place))) + (adjustable (restore-first (get-child "ADJUSTABLE" place))) + (res (make-array dimensions + :element-type element-type + :adjustable adjustable + :fill-pointer fill-pointer))) + (when displaced-to + (adjust-array res dimensions :displaced-to displaced-to + :displaced-index-offset displaced-offset)) + (resolving-object res + (loop for value in (xmls:node-children (get-child "VALUES" place)) + for count from 0 do + (let ((pos count)) + (setting (row-major-aref pos) + (restore-first value))))))) + + +#-(or allegro clisp) +(defstore-xml (obj simple-vector stream) + (with-tag ("SIMPLE-VECTOR" stream) + (princ-and-store "LENGTH" (length obj) stream) + (with-tag ("ELEMENTS" stream) + (loop for x across obj do + (princ-and-store "ELEMENT" x stream))))) + +#-(or allegro clisp) +(defrestore-xml (simple-vector place) + (let* ((size (restore-first (get-child "LENGTH" place))) + (res (make-array size))) + (resolving-object res + (loop for element in (xmls:node-children (get-child "ELEMENTS" place)) + for index from 1 do + (let ((copy (1- index))) + (setting (aref copy) + (restore-first element))))))) + + +|# +;; EOF Added: trunk/thirdparty/cl-store_0.8.4/xml-package.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/xml-package.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,130 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(defpackage #:cl-store-xml + (:use #:cl #:cl-store) + (:export #:*xml-backend* + #:add-xml-mapping #:defstore-xml #:defrestore-xml #:princ-and-store + #:princ-xml #:restore-first #:with-tag #:first-child + #:second-child #:get-child) + (:import-from #:cl-store #:when-let #:generic-function-name #:get-function-name + #:force #:setting #:resolving-object) + + #+sbcl (:import-from #:sb-mop + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+ecl (:import-from #:clos + #:generic-function-name + #:compute-slots + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:import-from #:pcl + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+cmu (:shadowing-import-from #:pcl + #:class-name + #:find-class + #:standard-class + #:class-of) + + #+openmcl (:import-from #:openmcl-mop + #:generic-function-name + #:slot-definition-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + + #+clisp (:import-from #:clos + #:slot-value + #:std-compute-slots + #:slot-boundp + #:class-name + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:ensure-class) + + #+lispworks (:import-from #:clos + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:compute-slots + #:slot-definition + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:class-direct-superclasses + #:ensure-class) + + #+allegro (:import-from #:mop + #:slot-definition-name + #:generic-function-name + #:slot-definition-allocation + #:slot-definition + #:compute-slots + #:slot-definition-initform + #:slot-definition-initargs + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-superclasses + #:class-slots + #:ensure-class) + ) + + +;; EOF \ No newline at end of file Added: trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp ============================================================================== --- (empty file) +++ trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp Mon Feb 18 09:40:18 2008 @@ -0,0 +1,17 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; See the file LICENCE for licence information. + +(in-package :cl-store-tests) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cl-store-xml)) + +(add-xml-mapping "RANDOM-OBJ") + +(defstore-xml (obj random-obj stream) + (princ-and-store "RANDOM-OBJ" (size obj) stream)) + +(defrestore-xml (random-obj stream) + (random (restore-first stream))) + +;; EOF \ No newline at end of file