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@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 @@ -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@common-lisp.net @@ -151,7 +177,7 @@

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: + * 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@jhb.ucs.co.za" :maintainer "Sean Ross sdr@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