[bknr-cvs] r2554 - in trunk/thirdparty/cl-store_0.8.4: . abcl acl allegrocl clisp cmucl doc ecl lispworks mcl openmcl sbcl
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Mon Feb 18 14:40:21 UTC 2008
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 at 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 at common-lisp.net>
+ * cl-store.asd: Release 0.8
+
+2007-09-09 Sean Ross <sross at common-lisp.net>
+ * sbcl/custom.lisp: be lenient when parsing parts of sbcls version string. Thanks to Gustavo.
+
+2007-01-26 Sean Ross <sross at 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 at 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 at 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 at 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 at 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 at 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 at common-lisp.net>
+ * lispworks/custom.lisp: Began work on new special float creation.
+ * .cvsignore : Update ignorable files
+
+2006-10-01 Sean Ross <sross at common-lisp.net>
+ * utils.lisp: Fix mkstr to upcase args.
+
+2006-08-03 Sean Ross <sross at 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 at common-lisp.net>
+ * sbcl/custom.lisp: Fixed sbcl structure definition
+ storing for versions >= 0.9.6.25 .
+
+2006-03-13 Sean Ross <sross at 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 at 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 at 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 at 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 at common-lisp.net>
+ * default-backend.lisp: Changed storing and restoring
+ of standard-object to not create unnecessary garbage.
+
+2005-09-09 Sean Ross <sross at 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 at 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 at 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 at 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 at 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 at 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 at 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 at common-lisp.net>
+ * doc/cl-store.texi: Fixed up to work properly with makeinfo.
+
+2005-03-15 Sean Ross <sross at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at common-lisp.net>
+ * package.lisp, acl/custom.lisp: Added support for Allegro CL.
+
+2004-10-13 Sean Ross <sross at 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 at 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 at common-lisp.net>
+ * default-backend: Added multiple-value-store.
+ * xml-backend: Added support for multiple return values.
+
+2004-10-07 Sean Ross <sross at common-lisp.net>
+ * circularities.lisp: Added support for multiple return values from
+ functions defined with defrestore-?.
+
+2004-10-06 Sean Ross <sross at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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))
+ , at 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))
+ , at 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))
+ , at 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))
+ , at 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)))
+ , at 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 () , at 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))
+ , at 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))))
+ , at 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 at jhb.ucs.co.za>"
+ :maintainer "Sean Ross <sdr at 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 at common-lisp.net>"
+ :maintainer "Sean Ross <sross at 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 -*-
+ at c %**start of header
+ at setfilename cl-store.texi
+ at settitle CL-STORE Manual
+
+
+ at dircategory Software development
+ at direntry
+* cl-store: (cl-store). CL Serialization Package
+ at end direntry
+
+ at 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.
+
+ at end copying
+
+ at c
+ at titlepage
+ at title CL-STORE: CL Serialization Package
+
+ at page
+ at vskip 0pt plus 1filll
+ at insertcopying
+ at end titlepage
+
+ at contents
+
+ at ifnottex
+
+ at node Top
+ at top CL-STORE: CL Serialization Package
+
+ at insertcopying
+
+ at menu
+* Introduction: Introduction
+* Getting Started: Getting Started
+* API: API
+* Customizing: Customizing
+* New Backends: New Backends
+* Notes: Notes
+* Credits: Credits
+* Index::
+
+ at end menu
+
+ at end ifnottex
+
+ at node Introduction
+ at 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.
+ at section Example
+ at 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"))
+ at end lisp
+
+
+ at section Supported Objects
+ at itemize @bullet
+ at item Numbers (floats, integers, complex, NaN floats, rationals)
+ at item Strings (Supports Unicode Strings)
+ at item Characters
+ at item Symbols
+ at item Packages
+ at item HashTables
+ at item Lists
+ at item Vectors And Arrays
+ at item Instances of CLOS Classes
+ at item CLOS Classes
+ at item Structure Instances
+ at item Structure Definitions (CMUCL and SBCL only)
+ at item Functions (stores the function name)
+ at item Generic Functions (stores generic-function-name)
+ at end itemize
+
+ at section Supported Implementations
+ at itemize @bullet
+ at item SBCL
+ at item CMUCL
+ at item CLISP
+ at item Lispworks
+ at item Allegro CL
+ at item OpenMCL
+ at item ECL
+ at end itemize
+
+
+ at node Getting Started
+ at 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}
+ at code{(require 'asdf)}
+
+
+ at section Downloading
+ at itemize
+ at 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
+ at 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.
+
+ at 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).
+
+ at 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.
+
+ at end itemize
+
+ at section Installing
+Once downloaded and symlinked you can load CL-STORE at anytime using
+ at code{(asdf:oos 'asdf:load-op :cl-store)}
+This will compile CL-STORE the first time it is loaded.
+
+ at 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
+ at code{(asdf:oos 'asdf:test-op :cl-store)}
+
+If any tests fail please send a message to one of the Mailing Lists.
+
+
+ at node API
+ at chapter API
+
+ at section Variables
+ at anchor{Variable *nuke-existing-classes*}
+ at vindex *nuke-existing-classes*
+ at deftp {Variable} *nuke-existing-classes* @emph{Default NIL}
+Determines wether or not to override existing classes when restoring a CLOS Class. If
+ at code{*nuke-existing-classes*} is not NIL the current definition will be overridden.
+ at end deftp
+
+ at anchor{Variable *store-class-superclasses*}
+ at vindex *store-class-superclasses*
+ at 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.
+ at end deftp
+
+ at anchor{Variable *store-class-slots*}
+ at vindex *store-class-slots*
+ at 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.
+ at end deftp
+
+
+ at anchor{Variable *nuke-existing-packages*}
+ at vindex *nuke-existing-packages*
+ at 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.
+ at end deftp
+
+ at anchor{Variable *store-used-packages*}
+ at vindex *store-used-packages*
+ at 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.
+ at end deftp
+
+ at anchor{Variable *store-hash-size*}
+ at vindex *store-hash-size*
+ at 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.
+ at end deftp
+
+ at anchor{Variable *restore-hash-size*}
+ at vindex *restore-hash-size*
+ at 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.
+ at end deftp
+
+
+ at anchor{Variable *check-for-circs*}
+ at vindex *check-for-circs*
+ at 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).
+ at end deftp
+
+ at anchor{Variable *default-backend*}
+ at vindex *default-backend*
+ at deftp {Variable} *default-backend*
+The backend that will be used by default.
+ at end deftp
+
+
+ at section Functions
+ at anchor{Generic store}
+ at 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.
+ at end deffn
+
+ at anchor{Generic restore}
+ at deffn {Generic} restore place &optional (backend *default-backend*)
+Restores an object serialized using @code{store} from @emph{place} using @emph{backend}.
+ at emph{Place} must be either a @code{stream} or a @code{pathname-designator}.
+Restore is setffable eg.
+ at lisp
+(store 0 "/tmp/counter")
+(incf (restore "/tmp/counter"))
+ at 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.
+ at end deffn
+
+
+ at anchor{Function find-backend}
+ at 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.
+ at end deffn
+
+ at anchor{Function caused-by}
+ at deffn {Function} caused-by cl-store-error
+Returns the @code{condition} which caused @code{cl-store-error} to be signalled.
+ at end deffn
+
+
+ at section Macros
+ at anchor{Macro with-backend}
+ at deffn {Macro} with-backend backend &body body
+Execute @emph{body} with @code{*default-backend*} bound to the
+backend designated by @emph{backend}.
+ at end deffn
+
+
+ at section Conditions
+ at anchor{Condition cl-store-error}
+ at 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}
+ at end deftp
+
+ at anchor{Condition store-error}
+ at deftp {Condition} store-error
+Class Precedence: @code{cl-store-error}
+
+A @code{store-error} will be signalled when an error occurs within
+ at code{store} or @code{multiple-value-store}. The causing error can be
+obtained using @code{(caused-by condition)}
+ at end deftp
+
+ at anchor{Condition restore-error}
+ at deftp {Condition} restore-error
+Class Precedence: @code{cl-store-error}
+
+A @code{restore-error} will be signalled when an error occurs within
+ at code{restore}. The causing error can be obtained using
+ at code{(caused-by condition)}
+ at end deftp
+
+
+ at node Customizing
+ at chapter Customizing
+
+ at 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
+ at 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.
+ at 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
+
+ at end lisp
+If you need to get fancier take a look at the macroexpansion of the customizing macros.
+ at vskip 0pt plus 1filll
+
+ at section Customizing API
+
+This API is primarily concerned with the cl-store-backend although other backends
+will be similar in structure.
+
+ at subsection Functions
+ at anchor{Function register-code}
+ at 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.
+ at end deffn
+
+ at anchor{Function output-type-code}
+ at 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.
+ at end deffn
+
+ at anchor{Function store-32-bit}
+ at deffn {Function} store-32-bit integer stream
+Outputs the the low 32 bits from @emph{integer} into @emph{stream}.
+ at end deffn
+
+ at anchor{Function read-32-bit}
+ at deffn {Function} read-32-bit stream
+Reads a 32-bit integer from @emph{stream}.
+ at end deffn
+
+ at anchor{Generic store-object}
+ at deffn {Generic} store-object object place
+Stores @emph{object} into @emph{place}. This should be used inside
+ at code{defstore-cl-store} to output parts of objects. @code{store}
+should not be used.
+ at end deffn
+
+ at anchor{Generic restore-object}
+ at deffn {Generic} restore-object place
+Restore an object, written out using @code{store-object} from @emph{place}.
+ at end deffn
+
+ at anchor{Generic get-slot-details}
+ at 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
+ at end deffn
+
+ at anchor{Generic serializable-slots}
+ at 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}.
+ at end deffn
+
+ at anchor{Generic serializable-slots-using-class}
+ at 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.
+ at 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))
+ at end lisp
+ at end deffn
+
+
+ at vskip 0pt plus 1filll
+
+ at subsection Macros
+ at anchor{Macro defstore-cl-store}
+ at 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.
+ at lisp
+(defstore-cl-store (obj ratio stream)
+ (output-type-code +ratio-code+ stream)
+ (store-object (numerator obj) stream)
+ (store-object (denominator obj) stream))
+
+ at end lisp
+ at end deffn
+
+ at anchor{Macro defrestore-cl-store}
+ at deffn {Macro} defrestore-cl-store (type stream) &body body
+Create a custom restoring mechanism for the @emph{type}
+registered using @code{register-code}. at emph{Body} will be executed with
+ at emph{stream} being the input stream to restore an object from.
+
+Example.
+ at lisp
+(defrestore-cl-store (ratio stream)
+ (/ (restore-object stream)
+ (restore-object stream)))
+ at end lisp
+ at end deffn
+
+ at anchor{Macro resolving-object}
+ at 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.
+ at lisp
+(defrestore-cl-store (cons stream)
+ (resolving-object (object (cons nil nil))
+ (setting (car object) (restore-object stream))
+ (setting (cdr object) (restore-object stream))))
+ at end lisp
+ at end deffn
+
+ at vskip 0pt plus 1filll
+
+ at anchor{Macro setting}
+ at 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.
+ at 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))
+ at end lisp
+ at end deffn
+
+ at anchor{Macro setting-hash}
+ at deffn {Macro} setting-hash getting-key getting-value
+ at 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.
+ at 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)))
+ at end lisp
+ at end deffn
+
+
+ at node New Backends
+ at chapter New Backends
+
+ at 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.
+
+
+ at section The Process
+
+ at 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)
+ at 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))))
+ at end lisp
+
+ at 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)
+ at 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))
+
+ at end lisp
+
+
+ at 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.
+ at 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)
+ at 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)))
+ at end lisp
+
+ at section Example: Simple Pickle Format
+As a short example we will define a backend that can handle simple objects
+using the python pickle format.
+
+ at subsection Define the backend
+ at lisp
+(in-package :cl-user)
+(use-package :cl-store)
+
+(defbackend pickle :stream-type 'character)
+ at end lisp
+ at vskip 0pt plus 2filll
+
+ at subsection Recognize Objects
+This is just a simple example to be able to handle single strings
+stored with Python's pickle module.
+
+ at 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)))))
+ at end lisp
+
+ at subsection Test the new Backend.
+This can be tested with the code
+ at 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'
+ at end lisp
+
+ at vskip 0pt plus 2filll
+
+ at section API
+
+ at subsection Functions
+ at anchor{Generic backend-restore}
+ at 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.
+ at end deffn
+
+ at anchor{Generic backend-restore-object}
+ at 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).
+ at end deffn
+
+ at anchor{Generic backend-store}
+ at 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.
+ at end deffn
+
+ at anchor{Generic backend-store-object}
+ at 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).
+ at end deffn
+
+ at anchor{Generic get-next-reader}
+ at 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.
+ at end deffn
+
+
+ at subsection Macros
+ at anchor{Macro defbackend}
+ at 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.
+ at end deffn
+
+ at node Notes
+ at chapter Notes
+
+ at section Backend Designators
+The @emph{backend} argument to store, restore and with-backend
+is a backend designator which can be one of.
+ at itemize @bullet
+ at item A backend returned by @code{(find-backend name)}
+ at item A symbol designating a backend (the first argument to defbackend).
+ at end itemize
+
+ at section Known Issues
+ at itemize @bullet
+ at item CLISP, OpenMCL, Allegro CL cannot store structure instances.
+ at item Structure definitions are only supported in SBCL and CMUCL.
+ at item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized.
+ at end itemize
+
+ at 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.
+ at lisp
+ :packages-to-keep '(:cl)
+ :keep-symbols '(cl:nil)
+ at end lisp
+
+ at 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.
+
+ at node Credits
+ at chapter Credits
+Thanks To
+ at itemize @bullet
+ at item Common-Lisp.net: For project hosting.
+ at item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks.
+ at item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends.
+ at item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements.
+ at item Killian Sprotte: Type specification fixups.
+ at end itemize
+
+ at node Index
+ at chapter Index
+
+ at section Function Index
+ at printindex fn
+
+ at section Variable Index
+ at printindex vr
+
+ at 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 at common-lisp.net">me</a> a line</li>
+ </ul>
+
+
+ <div class="footer">
+ <address>sross at 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 at 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)
+ , at 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
+ , at 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)
+ , at 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
More information about the Bknr-cvs
mailing list