[bknr-cvs] r2554 - in trunk/thirdparty/cl-store_0.8.4: . abcl acl allegrocl clisp cmucl doc ecl lispworks mcl openmcl sbcl

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

    

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

[bknr-cvs] r2554 - in trunk/thirdparty/cl-store_0.8.4: . abcl acl allegrocl clisp cmucl doc ecl lispworks mcl openmcl sbcl