Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv11891
Modified Files:
ChangeLog backends.lisp circularities.lisp cl-store.asd
default-backend.lisp package.lisp plumbing.lisp tests.lisp
utils.lisp
Log Message:
Changelog 2005-02-11
Date: Fri Feb 11 13:00:31 2005
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.19 cl-store/ChangeLog:1.20
--- cl-store/ChangeLog:1.19 Thu Feb 3 12:55:13 2005
+++ cl-store/ChangeLog Fri Feb 11 13:00:30 2005
@@ -1,3 +1,29 @@
+2005-02-11 Sean Ross <sross(a)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(a)common-lisp.net>
* default-backend.lisp: Fixed hash-table restoration,
it no longer assumes that the result of hash-table-test
@@ -10,7 +36,7 @@
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-setter*
+ to use delays allowing get-setf-place and *postfix-setters*
to be removed.
2004-12-02 Sean Ross <sross(a)common-lisp.net>
@@ -151,7 +177,7 @@
2004-05-21 Sean Ross <sross(a)common-lisp.net>
* store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp,
- tests.lisp, utils.lisp, cl-store.asd:
+ * 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.
Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.7 cl-store/backends.lisp:1.8
--- cl-store/backends.lisp:1.7 Tue Feb 1 09:27:26 2005
+++ cl-store/backends.lisp Fri Feb 11 13:00:31 2005
@@ -7,8 +7,6 @@
;; in default-backend.lisp and xml-backend.lisp
(in-package :cl-store)
-;(declaim (optimize (speed 3) (safety 1) (debug 0)))
-
(defun required-arg (name)
(error "~A is a required argument" name))
@@ -19,103 +17,93 @@
(old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers
:type integer)
(stream-type :accessor stream-type :initarg :stream-type :type symbol
- :initform (required-arg "stream-type"))
- (restorer-funs :accessor restorer-funs :initform (make-hash-table)
- :initarg :restorer-funs :type hash-table))
+ :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 mkstr (&rest args)
- (with-output-to-string (s)
- (dolist (x args)
- (princ x s))))
-
-(defun symbolicate (&rest syms)
- "Concatenate all symbol names into one big symbol"
- (values (intern (apply #'mkstr syms))))
+(defun find-backend (name)
+ (declare (type symbol name))
+ "Return backup called NAME or NIL if not found."
+ (cdr (assoc name *registered-backends*)))
+
+(defun backend-designator->backend (designator)
+ (check-type designator backend-designator)
+ (etypecase designator
+ (symbol (or (find-backend designator)
+ (error "~A does not designate a backend." designator)))
+ (backend designator)))
-(defun get-store-macro (name class-name)
+(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 &key qualifier)
+ `(defmacro ,macro-name ((var type stream &optional qualifier)
&body body)
- `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
- ((,var ,type) ,stream (backend ,',class-name))
- ,(format nil "Definition for storing an object of type ~A with ~
-backend ~A" type ',name)
- ,@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)))))
(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) &body body)
- (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
- `(flet ((,fn-name (,place)
- ,@body))
- (let* ((backend (find-backend ',',name))
- (restorers (restorer-funs backend)))
- (when (gethash ',type restorers)
- (warn "Redefining restorer ~A for backend ~(~A~)"
- ',type (name backend)))
- (setf (gethash ',type restorers)
- #',fn-name)))))))
-
-(defun real-stream-type (value)
- (ecase value
- (char 'character)
- (binary 'integer)))
+ `(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)
(declare (type symbol name))
- (assert (member stream-type '(char binary)))
(let ((instance (make-instance class
:name name
:magic-number magic-number
:old-magic-numbers old-magic-numbers
- :stream-type (real-stream-type stream-type))))
+ :stream-type stream-type)))
(if (assoc name *registered-backends*)
- (cerror "Redefine backend" "Backend is already defined ~A" name)
+ (cerror "Redefine backend" "Backend ~A is already defined." name)
(push (cons name instance) *registered-backends*))
instance))
-(defun find-backend (name)
- (declare (type symbol name))
- "Return backup called NAME or NIL if not found."
- (cdr (assoc name *registered-backends*)))
(defun get-class-form (name fields extends)
- `(defclass ,name (,extends)
+ `(defclass ,name ,extends
,fields
(:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)."
name))))
-(defmacro defbackend (name &key (stream-type (required-arg "stream-type"))
- (magic-number nil) fields (extends 'backend)
- (old-magic-numbers nil))
+(defmacro defbackend (name &key (stream-type ''(unsigned-byte 8))
+ (magic-number nil) fields (extends '(backend))
+ (old-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))
- (let ((class-name (symbolicate name '-backend)))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (prog2
- ,(get-class-form class-name fields extends)
- (register-backend ',name ',class-name ,magic-number
- ,stream-type ',old-magic-numbers)
- ,(get-store-macro name class-name)
- ,(get-restore-macro name)))))
-
+ `(eval-when (:load-toplevel :execute)
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,(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)))
(defmacro with-backend (backend &body body)
"Run BODY with *default-backend* bound to BACKEND"
- `(let ((*default-backend* (or (and (typep ,backend 'backend)
- ,backend)
- (error "~A is not a legal backend"
- ,backend))))
- ,@body))
+ (with-gensyms (gbackend)
+ `(let* ((,gbackend ,backend)
+ (*default-backend* (or (backend-designator->backend ,gbackend)
+ (error "~A is not a legal backend"
+ ,gbackend))))
+ ,@body)))
-;; EOF
\ No newline at end of file
+;; EOF
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.14 cl-store/circularities.lisp:1.15
--- cl-store/circularities.lisp:1.14 Tue Feb 1 09:27:26 2005
+++ cl-store/circularities.lisp Fri Feb 11 13:00:31 2005
@@ -19,8 +19,6 @@
;; programs according to the Hyperspec(notes in EQ).
(in-package :cl-store)
-;(declaim (optimize (speed 3) (safety 1) (debug 1)))
-
(defvar *check-for-circs* t)
@@ -42,14 +40,16 @@
"Resolve the possible referring object retrieved by GET and
set it into PLACE. Only usable within a resolving-object form."
(declare (ignore place get))
- (error "setting can only be used inside a resolving-object form."))
+ #+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))
- (error "setting-hash can only be used inside a resolving-object form."))
+ #+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
@@ -76,8 +76,7 @@
,@body
,var))))
-(defstruct referrer
- val)
+(defstruct referrer val)
(defun referred-value (referrer hash)
"Return the value REFERRER is meant to be by looking in HASH."
@@ -100,7 +99,7 @@
(let ((*stored-counter* 0)
(*stored-values* (make-hash-table :test #'eq :size *store-hash-size*)))
(store-backend-code backend place)
- (backend-store-object obj place backend)
+ (backend-store-object backend obj place)
obj))
(defun seen (obj)
@@ -122,9 +121,9 @@
"Do we need to check if this object has been stored before?"
(not (typep obj 'not-circ)))
-(defgeneric store-referrer (obj place backend)
+(defgeneric store-referrer (backend obj place)
(:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.")
- (:method ((obj t) (place t) (backend resolving-backend))
+ (:method ((backend resolving-backend) (obj t) (place t))
(store-error "store-referrer must be specialized for backend ~(~A~)."
(name backend))))
@@ -136,12 +135,12 @@
(update-seen obj))
nil))
-(defmethod backend-store-object ((obj t) (place t) (backend resolving-backend))
+(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 it place backend)
- (internal-store-object obj place backend)))
+ (store-referrer backend it place)
+ (internal-store-object backend obj place)))
;; Restoration.
(declaim (type (or fixnum null) *restore-counter*))
@@ -158,53 +157,36 @@
(*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*)))
(check-magic-number backend place)
(multiple-value-prog1
- (backend-restore-object place backend)
+ (backend-restore-object backend place)
(dolist (fn *need-to-fix*)
(force fn)))))
(defun update-restored (spot val)
(setf (gethash spot *restored-values*) val))
-(defun all-vals (reader place)
- (declare (type function reader))
- (multiple-value-list (funcall reader place)))
-
-(defun get-vals (reader place)
- (declare (type function reader))
- (mapcar #'new-val (all-vals reader place)))
-
-(defun handle-values (reader place)
+(defun handle-normal (backend reader place)
(let ((spot (incf *restore-counter*))
- (vals (get-vals reader place)))
- (update-restored spot (car vals))
- (values-list vals)))
-
-(defun call-it (reader place)
- (funcall (the function reader) place))
-
-(defun handle-normal (reader place)
- (let ((spot (incf *restore-counter*))
- (vals (new-val (call-it reader place))))
+ (vals (new-val (internal-restore-object backend reader place))))
(update-restored spot vals)
vals))
+(defgeneric referrerp (backend reader))
+
(defun handle-restore (place backend)
- (multiple-value-bind (reader sym) (find-function-for-type place backend)
- (declare (type function reader) (type symbol sym))
- (cond ((eql sym 'values-object)
- (handle-values reader place))
- ((eql sym 'referrer)
+ (multiple-value-bind (reader) (get-next-reader backend place)
+ (declare (type symbol reader))
+ (cond ((referrerp backend reader)
(incf *restore-counter*)
- (new-val (call-it reader place)))
- ((not (int-sym-or-char-p backend sym))
- (handle-normal reader place))
- (t (new-val (funcall reader place))))))
+ (new-val (internal-restore-object backend reader place)))
+ ((not (int-sym-or-char-p backend reader))
+ (handle-normal backend reader place))
+ (t (new-val (internal-restore-object backend reader place))))))
-(defmethod backend-restore-object ((place stream) (backend resolving-backend))
+(defmethod backend-restore-object ((backend resolving-backend) (place stream))
"Retrieve a object from PLACE, does housekeeping for circularity fixing."
(if *check-for-circs*
(handle-restore place backend)
- (funcall (the function (find-function-for-type place backend)) place)))
+ (call-next-method)))
(defgeneric int-sym-or-char-p (backend fn)
(:method ((backend backend) (fn symbol))
@@ -220,5 +202,4 @@
val)
val))
-
-;; EOF
\ No newline at end of file
+;; EOF
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.18 cl-store/cl-store.asd:1.19
--- cl-store/cl-store.asd:1.18 Thu Feb 3 12:59:12 2005
+++ cl-store/cl-store.asd Fri Feb 11 13:00:31 2005
@@ -40,7 +40,7 @@
:name "CL-STORE"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.4.6"
+ :version "0.4.13"
:description "Serialization package"
:long-description "Portable CL Package to serialize data types"
:licence "MIT"
@@ -65,9 +65,7 @@
:components ((:file "tests")))
(defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests))))
- (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
- (symbol-value (find-symbol "*CL-STORE-BACKEND*" "CL-STORE")))
- (error "Test-op Failed.")))
-
+ (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
+ (find-symbol "CL-STORE" "CL-STORE")))
;; EOF
Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.17 cl-store/default-backend.lisp:1.18
--- cl-store/default-backend.lisp:1.17 Thu Feb 3 12:55:13 2005
+++ cl-store/default-backend.lisp Fri Feb 11 13:00:31 2005
@@ -2,66 +2,68 @@
;; See the file LICENCE for licence information.
;; The cl-store backend.
-
(in-package :cl-store)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *cl-store-backend*
- (defbackend cl-store :magic-number 1886611820
- :stream-type 'binary
- :old-magic-numbers (1912923 1886611788 1347635532
- 1884506444 1347643724 1349732684)
- :extends resolving-backend
- :fields ((restorers :accessor restorers
- :initform (make-hash-table :size 100)))))
- (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))
+(defbackend cl-store :magic-number 1349740876
+ :stream-type '(unsigned-byte 8)
+ :old-magic-numbers (1912923 1886611788 1347635532 1886611820
+ 1884506444 1347643724 1349732684)
+ :extends (resolving-backend)
+ :fields ((restorers :accessor restorers
+ :initform (make-hash-table :size 100))))
+
+(defun register-code (code name &optional (errorp t))
+ (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
-(defconstant +referrer-code+ (register-code 1 'referrer nil))
-(defconstant +values-code+ (register-code 2 'values-object nil))
-(defconstant +unicode-string-code+ (register-code 3 'unicode-string nil))
-(defconstant +integer-code+ (register-code 4 'integer nil))
-(defconstant +simple-string-code+ (register-code 5 'simple-string nil))
-(defconstant +float-code+ (register-code 6 'float nil))
-(defconstant +ratio-code+ (register-code 7 'ratio nil))
-(defconstant +character-code+ (register-code 8 'character nil))
-(defconstant +complex-code+ (register-code 9 'complex nil))
-(defconstant +symbol-code+ (register-code 10 'symbol nil))
-(defconstant +cons-code+ (register-code 11 'cons nil))
-(defconstant +pathname-code+ (register-code 12 'pathname nil))
-(defconstant +hash-table-code+ (register-code 13 'hash-table nil))
-(defconstant +standard-object-code+ (register-code 14 'standard-object nil))
-(defconstant +condition-code+ (register-code 15 'condition nil))
-(defconstant +structure-object-code+ (register-code 16 'structure-object nil))
-(defconstant +standard-class-code+ (register-code 17 'standard-class nil))
-(defconstant +built-in-class-code+ (register-code 18 'built-in-class nil))
-(defconstant +array-code+ (register-code 19 'array nil))
-(defconstant +simple-vector-code+ (register-code 20 'simple-vector nil))
-(defconstant +package-code+ (register-code 21 'package nil))
+(defvar +referrer-code+ (register-code 1 'referrer nil))
+;(defvar +values-code+ (register-code 2 'values-object nil))
+(defvar +unicode-string-code+ (register-code 3 'unicode-string nil))
+(defvar +integer-code+ (register-code 4 'integer nil))
+(defvar +simple-string-code+ (register-code 5 'simple-string nil))
+(defvar +float-code+ (register-code 6 'float nil))
+(defvar +ratio-code+ (register-code 7 'ratio nil))
+(defvar +character-code+ (register-code 8 'character nil))
+(defvar +complex-code+ (register-code 9 'complex nil))
+(defvar +symbol-code+ (register-code 10 'symbol nil))
+(defvar +cons-code+ (register-code 11 'cons nil))
+(defvar +pathname-code+ (register-code 12 'pathname nil))
+(defvar +hash-table-code+ (register-code 13 'hash-table nil))
+(defvar +standard-object-code+ (register-code 14 'standard-object nil))
+(defvar +condition-code+ (register-code 15 'condition nil))
+(defvar +structure-object-code+ (register-code 16 'structure-object nil))
+(defvar +standard-class-code+ (register-code 17 'standard-class nil))
+(defvar +built-in-class-code+ (register-code 18 'built-in-class nil))
+(defvar +array-code+ (register-code 19 'array nil))
+(defvar +simple-vector-code+ (register-code 20 'simple-vector nil))
+(defvar +package-code+ (register-code 21 'package nil))
;; Used by lispworks
-(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity nil))
-(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity nil))
+(defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil))
+(defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil))
;; new storing for 32 bit ints
-(defconstant +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
+(defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
;; More for lispworks
-(defconstant +float-nan-code+ (register-code 25 'nan-float nil))
+(defvar +float-nan-code+ (register-code 25 'nan-float nil))
-(defconstant +function-code+ (register-code 26 'function nil))
-(defconstant +gf-code+ (register-code 27 'generic-function nil))
+(defvar +function-code+ (register-code 26 'function nil))
+(defvar +gf-code+ (register-code 27 'generic-function nil))
;; Used by SBCL and CMUCL.
-(defconstant +structure-class-code+ (register-code 28 'structure-class nil))
-(defconstant +struct-def-code+ (register-code 29 'struct-def nil))
+(defvar +structure-class-code+ (register-code 28 'structure-class nil))
+(defvar +struct-def-code+ (register-code 29 'struct-def nil))
+
+(defvar +gensym-code+ (register-code 30 'gensym nil))
-(defconstant +gensym-code+ (register-code 30 'gensym nil))
+(defvar +positive-double-infinity-code+ (register-code 31 'positive-double-infinity nil))
+(defvar +negative-double-infinity-code+ (register-code 32 'negative-double-infinity nil))
+(defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil))
;; setups for type code mapping
(defun output-type-code (code stream)
@@ -71,24 +73,25 @@
(defun read-type-code (stream)
(read-byte stream))
-(defvar *restorers* (restorers *cl-store-backend*))
+(defmethod referrerp ((backend cl-store) (reader t))
+ (eql reader 'referrer))
+
+(defvar *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)
(gethash code *restorers*))
-(defmethod get-next-reader ((stream stream) (backend cl-store-backend))
- (declare (ignore backend))
+(defmethod get-next-reader ((backend cl-store) (stream stream))
(let ((type-code (read-type-code stream)))
- (or (lookup-code type-code) ;(gethash type-code *restorers*)
- (values nil (format nil "Type ~A" type-code)))))
+ (or (lookup-code type-code)
+ (error "Type code ~A is not registered." type-code))))
;; referrer, Required for a resolving backend
-(defmethod store-referrer (ref stream (backend cl-store-backend))
- (declare (ignore backend))
+(defmethod store-referrer ((backend cl-store) (ref t) (stream t))
(output-type-code +referrer-code+ stream)
(dump-int ref stream))
@@ -101,8 +104,7 @@
;; so we we have a little optimization for it
;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((backend cl-store-backend) (fn symbol))
- (declare (ignore backend))
+(defmethod int-sym-or-char-p ((backend cl-store) (fn symbol))
(find fn '(integer character 32-bit-integer symbol)))
(defstore-cl-store (obj integer stream)
@@ -162,29 +164,63 @@
(- result)
result)))
-;; Floats
-;; SBCL and CMUCL use a different mechanism for dealing
-;; with floats which supports infinities.
-;; Lispworks uses a slightly different version as well
-;; manually handling negative and positive infinity
-;; Allegro uses excl:double-float-to-shorts and friends
-#-(or lispworks cmu sbcl allegro)
+;; Floats (*special-floats* are setup in the custom.lisp files)
+(defvar *special-floats* nil)
+
(defstore-cl-store (obj float stream)
- (output-type-code +float-code+ stream)
- (multiple-value-bind (significand exponent sign)
- (integer-decode-float obj)
- (write-byte (float-type obj) stream)
- (store-object significand stream)
- (store-object exponent stream)
- (store-object sign stream)))
+ (block body
+ (let (significand exponent sign)
+ (handler-bind ((simple-error
+ #'(lambda (err)
+ (declare (ignore err))
+ (awhen (cdr (assoc obj *special-floats*))
+ (output-type-code it 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)))))
-#-(or cmu sbcl allegro)
(defrestore-cl-store (float stream)
(float (* (get-float-type (read-byte stream))
(* (restore-object stream)
- (expt 2 (restore-object stream)))
+ (expt (restore-object stream)
+ (restore-object stream)))
(restore-object stream))))
+(defun handle-special-float (code name)
+ (aif (rassoc code *special-floats*)
+ (car it)
+ (store-error "~A Cannot be represented." name)))
+
+(defrestore-cl-store (negative-infinity stream)
+ (handle-special-float +negative-infinity-code+
+ "Single Float Negative Infinity"))
+
+(defrestore-cl-store (positive-infinity stream)
+ (handle-special-float +positive-infinity-code+
+ "Single Float Positive Infinity"))
+
+(defrestore-cl-store (nan-float stream)
+ (handle-special-float +float-nan-code+ "Single Float NaN"))
+
+(defrestore-cl-store (negative-double-infinity stream)
+ (handle-special-float +negative-double-infinity-code+
+ "Double Float Negative Infinity"))
+
+(defrestore-cl-store (positive-double-infinity stream)
+ (handle-special-float +positive-double-infinity-code+
+ "Double Float Positive Infinity"))
+
+(defrestore-cl-store (float-double-nan stream)
+ (handle-special-float +float-double-nan-code+
+ "Double Float NaN"))
+
+
;; ratio
(defstore-cl-store (obj ratio stream)
(output-type-code +ratio-code+ stream)
@@ -231,7 +267,7 @@
(defrestore-cl-store (gensym stream)
(make-symbol (restore-object stream)))
-
+
;; lists
(defstore-cl-store (obj cons stream)
(output-type-code +cons-code+ stream)
@@ -245,6 +281,7 @@
(setting (car x) (restore-object stream))
(setting (cdr x) (restore-object stream))))
+
;; pathnames
(defstore-cl-store (obj pathname stream)
(output-type-code +pathname-code+ stream)
@@ -297,7 +334,6 @@
(restore-object stream))))
hash)))
-
;; Object and Conditions
(defun store-type-object (obj stream)
(let* ((all-slots (remove-if-not (lambda (x)
@@ -321,7 +357,6 @@
(output-type-code +standard-object-code+ stream)
(store-type-object obj stream))
-#-lispworks
(defstore-cl-store (obj condition stream)
(output-type-code +condition-code+ stream)
(store-type-object obj stream))
@@ -339,11 +374,10 @@
(setting (slot-value obj slot-name) (restore-object stream)))))
new-instance))
-#-lispworks
-(defrestore-cl-store (condition stream)
+(defrestore-cl-store (standard-object stream)
(restore-type-object stream))
-(defrestore-cl-store (standard-object stream)
+(defrestore-cl-store (condition stream)
(restore-type-object stream))
@@ -377,12 +411,14 @@
#+clisp (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 ((obj (eql (find-class 'hash-table))) stream
- (backend cl-store-backend))
+ (backend cl-store))
(output-type-code +built-in-class-code+ stream)
(store-object 'cl:hash-table stream))
@@ -505,17 +541,6 @@
(find-package (restore-object stream)))
-;; multiple values
-
-(defstore-cl-store (obj values-object stream)
- (output-type-code +values-code+ stream)
- (store-object (vals obj) stream))
-
-(defrestore-cl-store (values-object stream)
- (apply #'values (restore-object stream)))
-
-
-
;; Function storing hack.
;; This just stores the function name if we can find it
;; or signal a store-error.
@@ -570,6 +595,7 @@
(defrestore-cl-store (generic-function stream)
(fdefinition (restore-object stream)))
+
(setf *default-backend* (find-backend 'cl-store))
Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.16 cl-store/package.lisp:1.17
--- cl-store/package.lisp:1.16 Tue Feb 1 09:27:26 2005
+++ cl-store/package.lisp Fri Feb 11 13:00:31 2005
@@ -1,33 +1,28 @@
;;; -*- 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 #:restorer-funs
+ (:export #:backend #:magic-number #:stream-type
#:restorers #:resolving-backend #:find-backend #:defbackend
#:*restore-counter* #:*need-to-fix* #:*restored-values*
#:with-backend #:fix-circularities #:*default-backend*
- #:*cl-store-backend* #:*current-backend* #:*store-class-slots*
+ #:*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 #:get-class-details #:get-array-values
- #:restore #:backend-restore
+ #:restore #:backend-restore #:cl-store #:referrerp
#:check-magic-number #:get-next-reader #:int-sym-or-char-p
#:restore-object #:backend-restore-object
#: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 #:compute-slots
- #:slot-definition-allocation #:slot-definition-name
- #:slot-definition-type #:slot-definition-initargs
- #:slot-definition-readers #:slot-definition-writers
- #:class-direct-superclasses #:class-direct-slots
- #:ensure-class #:make-referrer #:setting-hash
+ #:float-type #:get-float-type #:make-referrer #:setting-hash
#:multiple-value-store #:*postfix-setters* #:caused-by
#:store-32-bit #:read-32-bit #:*check-for-circs*
#:*store-hash-size* #:*restore-hash-size*)
-
+
#+sbcl (:import-from #:sb-mop
#:generic-function-name
#:slot-definition-name
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.9 cl-store/plumbing.lisp:1.10
--- cl-store/plumbing.lisp:1.9 Tue Feb 1 09:27:26 2005
+++ cl-store/plumbing.lisp Fri Feb 11 13:00:31 2005
@@ -53,25 +53,21 @@
(error 'restore-error :format-string format-string :format-args args))
-
-
;; entry points
(defun store-to-file (obj place backend)
(declare (type backend backend))
- (let* ((backend-type (stream-type backend))
- (element-type (ecase backend-type
- (character 'character)
- (integer '(unsigned-byte 8)))))
+ (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 backend)
+(defgeneric store (obj place &optional designator)
(:documentation "Entry Point for storing objects.")
- (:method ((obj t) (place t) &optional (backend *default-backend*))
+ (:method ((obj t) (place t) &optional (designator *default-backend*))
"Store OBJ into Stream PLACE using backend BACKEND."
- (let ((*current-backend* backend)
- (*read-eval* nil))
+ (let* ((backend (backend-designator->backend designator))
+ (*current-backend* backend)
+ (*read-eval* nil))
(handler-bind ((error (lambda (c)
(signal (make-condition 'store-error
:caused-by c)))))
@@ -104,20 +100,20 @@
(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 obj stream backend))
+ (backend-store-object backend obj stream))
-(defgeneric backend-store-object (obj stream backend)
+(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 ((obj t) (stream t) (backend backend))
+ (:method ((backend backend) (obj t) (stream t))
"The default, just calls internal-store-object."
- (internal-store-object obj stream backend)))
+ (internal-store-object backend obj stream)))
-(defgeneric internal-store-object (obj place backend)
+(defgeneric internal-store-object (backend obj place)
(:documentation "Method which is specialized by defstore-? macros.")
- (:method ((obj t) (place t) (backend backend))
+ (: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))))
@@ -127,10 +123,11 @@
(:documentation
"Restore and object FROM PLACE using BACKEND. Not meant to be
overridden, use backend-restore instead")
- (:method (place &optional (backend *default-backend*))
+ (:method (place &optional (designator *default-backend*))
"Entry point for restoring objects (setfable)."
- (let ((*current-backend* backend)
- (*read-eval* nil))
+ (let* ((backend (backend-designator->backend designator))
+ (*current-backend* backend)
+ (*read-eval* nil))
(handler-bind ((error (lambda (c)
(signal (make-condition 'restore-error
:caused-by c)))))
@@ -143,7 +140,7 @@
"Restore the object found in stream PLACE using backend BACKEND.
Checks the magic-number and invokes backend-restore-object"
(check-magic-number backend place)
- (backend-restore-object place backend))
+ (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))
@@ -152,10 +149,7 @@
(restore-from-file place backend)))
(defun restore-from-file (place backend)
- (let* ((backend-type (stream-type backend))
- (element-type (ecase backend-type
- (character 'character)
- (integer '(unsigned-byte 8)))))
+ (let* ((element-type (stream-type backend)))
(with-open-file (s place :element-type element-type :direction :input)
(backend-restore backend s))))
@@ -164,18 +158,10 @@
(:documentation "Backends supporting multiple return values
should define a custom storer and restorer for this class"));
-(defmacro multiple-value-store (values-form place
- &optional (backend '*default-backend*))
- "Store all values returned from VALUES-FORM into PLACE"
- `(let ((vals (multiple-value-list ,values-form)))
- (store (make-instance 'values-object :vals vals)
- ,place ,backend)
- (apply #'values vals)))
-
(defun (setf restore) (new-val place)
(store new-val place))
-(defgeneric check-magic-number (stream 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))
@@ -195,47 +181,33 @@
(defun lookup-reader (val readers)
(gethash val readers))
-(defgeneric get-next-reader (place backend)
+(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 ((place t) (backend backend))
+ (: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))))
-(defun find-function-for-type (place backend)
- (declare (type backend backend))
-;; (:documentation
-;; "Return a function registered with defrestore-? which knows
-;; how to retrieve an object from PLACE, uses get-next-reader.")
-;; (:method ((place t) (backend backend))
- (multiple-value-bind (val info) (get-next-reader place backend)
- (let ((reader (lookup-reader val (restorer-funs backend))))
- (cond ((and val reader) (values reader val))
- ((not val)
- (restore-error "~A is not registered with backend ~(~A~)."
- (or info "Unknown Type") (name backend)))
- ((not reader)
- (restore-error "No restorer defined for ~A in backend ~(~A~)."
- val (name backend)))))))
-
;; Wrapper for backend-restore-object so we don't have to pass
;; a backend object around all the time
(declaim (inline restore-object))
(defun restore-object (place &optional (backend *current-backend*))
"Restore the object in PLACE using BACKEND"
- (backend-restore-object place backend))
-
+ (backend-restore-object backend place))
-(defgeneric backend-restore-object (place backend)
+(defgeneric backend-restore-object (backend place)
(:documentation
"Find the next function to call with BACKEND and invoke it with PLACE.")
- (:method ((place t) (backend backend))
+ (:method ((backend backend) (place t))
"The default"
- (funcall (the function (find-function-for-type place backend)) place)))
+ (internal-restore-object backend (get-next-reader backend place) place)))
+
+(defgeneric internal-restore-object (backend type place))
;; EOF
Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.13 cl-store/tests.lisp:1.14
--- cl-store/tests.lisp:1.13 Tue Feb 1 09:27:26 2005
+++ cl-store/tests.lisp Fri Feb 11 13:00:31 2005
@@ -172,15 +172,20 @@
;; hash tables
+; for some reason (make-hash-table) is not equalp
+; to (make-hash-table) with ecl.
+
+#-ecl
(deftestit hash.1 (make-hash-table))
-(deftestit hash.2
- (let ((val #.(let ((in (make-hash-table :test #'equal
+#-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)))
- val))
+ in))
+#-ecl
+(deftestit hash.2 *hash*)
;; packages
@@ -211,7 +216,7 @@
(deftest standard-object.2
(let ((val (store (make-instance 'bar
:x (list 1 "foo" 1.0)
- :y (make-hash-table :test #'equal))
+ :y #(1 2 3 4))
*test-file*)))
(let ((ret (restore *test-file*)))
(and (equalp (get-x val) (get-x ret))
@@ -467,22 +472,10 @@
t)
-(deftest values.1
- (progn (multiple-value-store (values 1 2 3) *test-file*)
- (multiple-value-list (restore *test-file*)))
- (1 2 3))
-
-(deftest values.2
- (let ((string "foo"))
- (multiple-value-store (values string string) *test-file*)
- (let ((val (multiple-value-list (restore *test-file*))))
- (eq (car val) (cadr val))))
- t)
-
(deftestit function.1 #'restores)
(deftestit function.2 #'car)
-#-(or clisp lispworks allegro openmcl)
+#-(or clisp lispworks allegro openmcl ecl)
(deftestit function.3 #'(setf car))
(deftestit gfunction.1 #'cl-store:restore)
Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.10 cl-store/utils.lisp:1.11
--- cl-store/utils.lisp:1.10 Thu Feb 3 12:55:13 2005
+++ cl-store/utils.lisp Fri Feb 11 13:00:31 2005
@@ -94,5 +94,13 @@
(defun kwd (name)
(values (intern (string-upcase name) :keyword)))
+(defun mkstr (&rest args)
+ (with-output-to-string (s)
+ (dolist (x args)
+ (princ x s))))
+
+(defun symbolicate (&rest syms)
+ "Concatenate all symbol names into one big symbol"
+ (values (intern (apply #'mkstr syms))))
;; EOF
