Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv9569 Modified Files: utils.lisp tests.lisp package.lisp cl-store.asd circularities.lisp README ChangeLog .cvsignore Added Files: xml-backend.lisp test.lisp plumbing.lisp default-backend.lisp backends.lisp Removed Files: store.lisp fast-io.lisp Log Message: Changelog 2004-07-29 Date: Tue Aug 17 04:12:43 2004 Author: sross Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.2 cl-store/utils.lisp:1.3 --- cl-store/utils.lisp:1.2 Fri May 21 07:14:40 2004 +++ cl-store/utils.lisp Tue Aug 17 04:12:43 2004 @@ -1,77 +1,27 @@ ;;; -*- 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 conseq &optional (else nil)) +(declaim (optimize (speed 3) (safety 0) (debug 0))) + + + +(defmacro aif (test then &optional else) `(let ((it ,test)) - (declare (ignorable it)) - (if it ,conseq - (macrolet ((setf-it (val) (list 'setf ',test val))) - ,else)))) + (if it ,then ,else))) (defmacro with-gensyms (names &body body) `(let ,(mapcar #'(lambda (x) `(,x (gensym))) names) - ,@body)) + ,@body)) (defun mappend (fn &rest lsts) (apply #'append (apply #'mapcar fn lsts))) -(defvar *store-class-slots* t - "Whether or not to serialize class allocation slots.") - -(defun object-slot-and-vals (object) - "Create a plist containing slot names and values -for all bound slots in OBJECT. If *store-class-slots* is not -null then include slots which are class allocated." - (remove-if - #'null - (mapcar #'(lambda (x) - (let ((slot-name (slot-definition-name x))) - (when (and (slot-boundp object slot-name) - (or *store-class-slots* - (and (not *store-class-slots*) - (eq (slot-definition-allocation x) - :class)))) - (list slot-name - (slot-value object slot-name))))) - (compute-slots (class-of object))))) - - -(defun group (source n) - "Group from Paul Graham's on Lisp." - (declare (fixnum n)) - (if (zerop n) (error "N is zero, must be a positive fixnum.")) - (labels ((rec (source acc) - (let ((rest (nthcdr n source))) - (if (consp rest) - (rec rest (cons (subseq source 0 n) acc)) - (nreverse (cons source acc)))))) - (rec source nil))) - -(defun group-array (values subscripts) - "Group VALUES, a flattened list of array values, into a suitable -list to be used as :initial-contents to make-array according to SUBSCRIPTS." - (if (cdr subscripts) - (group-array (group values (car subscripts)) (cdr subscripts)) - values)) - -(defun get-array-values (array) - "Returns a suitable list to be used for :initial-contents -or :initial-element to make-array" - (when (zerop (array-total-size array)) - (return-from get-array-values nil)) - (let ((val (loop for x from 0 to (1- (array-total-size array)) - collect (row-major-aref array x)))) - (declare (type list val)) - (if (every #'(lambda (x) (equal x (car val))) val) - `(:initial-element ,(car val)) - `(:initial-contents ,(group-array - val - (nreverse (array-dimensions array))))))) - - (defun get-slot-details (slot-definition) + "Return a list of slot details which can be + used as an argument to ensure-class" (list :name (slot-definition-name slot-definition) :allocation (slot-definition-allocation slot-definition) :initargs (slot-definition-initargs slot-definition) @@ -82,23 +32,20 @@ :writers (slot-definition-writers slot-definition))) (defun get-class-details (x) + "Return a list of class details which can be + used as arguments to ensure-class" (list (class-name x) - (class-direct-default-initargs x) + ;; can't use this value either (see get-slot-details) + ;;(class-direct-default-initargs x) (mapcar #'get-slot-details (class-direct-slots x)) (mapcar #'class-name (class-direct-superclasses x)) (type-of x))) -;; where this package seems to spend a large portion of its time -(defun circular-listp (x) - (handler-case (not (list-length x)) - (type-error (c) (declare (ignore c)) nil))) - - (defmacro awhen (test &body body) `(aif ,test - (progn ,@body))) + (progn ,@body))) ;; because clisp doesn't have the class single-float or double-float. @@ -114,4 +61,35 @@ (1 1.0d0))) -;; EOF +(defun store-32-byte (obj stream) + "Write OBJ down STREAM as a 32 byte integer." + (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)) + + +(defun read-32-byte (buf &optional (signed t)) + "Read a signed or unsigned byte off STREAM." + (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 (+ byte1 (* 256 (+ byte2 (* 256 (+ byte3 (* 256 byte4)))))))) + (if (and signed (> byte1 127)) + (logior (ash -1 32) ret) + ret)))) + + +(defun store-string-code (string stream) + "Write length of STRING then STRING into stream" + (declare (type simple-string string)) + (format stream "~S" string)) + +(defun retrieve-string-code (stream) + "Retrieve a String written by store-string-code from STREAM" + (read stream)) + + +;; EOF \ No newline at end of file Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.3 cl-store/tests.lisp:1.4 --- cl-store/tests.lisp:1.3 Fri May 21 07:14:40 2004 +++ cl-store/tests.lisp Tue Aug 17 04:12:43 2004 @@ -8,7 +8,7 @@ (rem-all-tests) -(defvar *test-file* "filetest.dat") +(defvar *test-file* "filetest.cls") (defun restores (val) (store val *test-file*) @@ -82,7 +82,8 @@ (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.2 (make-array 5 :element-type 'fixnum + :initial-contents (list 1 2 3 4 5))) (deftestit vector.3 (make-array 5 @@ -109,8 +110,19 @@ (deftestit array.4 (make-array '(2 3 5) :initial-contents - '(((1 2 #\f 5 6) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1)) - ((0 #\a #\b 4 #\q) (4 0 '(d) 4 1) (#\Newline 1 7 #\4 #\0))))) + '(((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 @@ -137,7 +149,8 @@ (deftestit hash.1 (make-hash-table)) (deftestit hash.2 - (let ((val #.(let ((in (make-hash-table :test #'equal :rehash-threshold 0.4 :size 20 + (let ((val #.(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))) @@ -148,43 +161,88 @@ (deftestit package.1 (find-package :cl-store)) -;; standard-object -(defun object-equalp (obj1 obj2) - (typecase obj1 - ((or standard-object condition) - (equalp (cl-store::object-slot-and-vals obj1) - (cl-store::object-slot-and-vals obj2))) - (t (equalp obj1 obj2)))) +;; 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*))) - (object-equalp val (restore *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 (make-hash-table :test #'equal)) *test-file*))) - (object-equalp val (restore *test-file*))) + (let ((ret (restore *test-file*))) + (and (equalp (get-x val) (get-x ret)) + (equalp (get-y val) (get-y ret))))) t) -#-clisp -(deftestit standard-class.1 (find-class 'foo)) -#-clisp -(deftestit standard-class.2 (find-class 'bar)) +(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 - (let ((val (handler-case (/ 1 0) - (division-by-zero (c) (store c *test-file*))))) - (object-equalp val (restore *test-file*))) + (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")) + (type-error (c) + (store c *test-file*) + (typep (restore *test-file*) 'type-error))) t) ;; structure-object @@ -195,11 +253,11 @@ (defstruct (b (:include a)) d e f) -#-(or clisp lispworks) +#+(or sbcl cmu) (deftestit structure-object.1 (make-a :a 1 :b 2 :c 3)) -#-(or clisp lispworks) +#+(or sbcl cmu) (deftestit structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6)) -#-(or clisp lispworks) +#+(or sbcl cmu) (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))) @@ -211,7 +269,9 @@ (deftestit pathname.1 #P"/home/foo") (deftestit pathname.2 (make-pathname :name "foo")) - +(deftestit pathname.3 (make-pathname :name "foo" :type "bar" + #-clisp :device #-clisp "foobar" + )) ;; circular objects @@ -221,9 +281,9 @@ (let ((x (restore *test-file*))) (eq (cddddr x) x))) t) - + (defvar circ2 (let ((x (list 2 3 4 4 5))) - (setf (second x) x))) + (setf (second x) x))) (deftest circ.2 (progn (store circ2 *test-file*) (let ((x (restore *test-file*))) (eq (second x) x))) @@ -260,110 +320,141 @@ (gethash 'first x)))))) t) - - - -(defvar circ5 (let ((x (make-instance 'bar))) - (setf (get-y x) x) - x)) - -(deftest circ.5 (progn (store circ5 *test-file*) - (let ((x (restore *test-file*))) - (eq x (get-y x)))) +(deftest circ.5 (let ((circ5 (make-instance 'bar))) + (setf (get-y circ5) circ5) + (store circ5 *test-file*) + (let ((x (restore *test-file*))) + (eq x (get-y x)))) t) (defvar circ6 (let ((y (make-array '(2 2 2) - :initial-contents '(((1 2) (3 4)) - ((5 6) (7 8))) - :element-type 'integer))) + :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*))) - (eq (aref x 1 1 1) x))) + (and (eq (aref x 1 1 1) x) + (eq (aref x 0 0 0) (aref x 1 1 1))))) t) (defvar circ7 (let ((x (make-a))) (setf (a-a x) x))) -#-(or clisp lispworks) + +#+(or sbcl cmu) (deftest circ.7 (progn (store circ7 *test-file*) (let ((x (restore *test-file*))) (eq (a-a x) x))) t) +(defvar circ.8 (let ((x "foo")) + (make-pathname :name x :type x))) -(defvar *count* 1) -(defvar *inc* 1) -(defclass foobar ()()) -(defclass barfoo ()()) - -(defstore (obj foobar buff :qualifier :before) - (store-executable '(incf *count*) buff)) - -(deftest executable.1 - (progn (store (make-instance 'foobar) *test-file*) - (restore *test-file*) - (= *count* (incf *inc*))) +;; clisp apparently creates a copy of the strings in a pathname +#-clisp +(deftest circ.8 (progn (store circ.8 *test-file*) + (let ((x (restore *test-file*))) + (eq (pathname-name x) + (pathname-type x)))) t) -(defvar *hash* (make-hash-table)) - - -(defstore (obj barfoo buff :qualifier :before) - (store-executable `(let ((foo *hash*)) - (setf (gethash 1 foo) - ,obj) - (setf *hash* foo)) - buff)) - -(deftest executable.2 - (progn (store (make-instance 'barfoo) *test-file*) - (let ((x (restore *test-file*))) - (eq x (gethash 1 *hash*)))) +(deftest circ.9 (let ((val #("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 (eq rest (aref rest 3)) + (eq (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*))) + (eq 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*))) + (eq val (gethash val val)))) + t) + +(deftest circ.12 (let ((x #(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 (eq (aref ret 0) ret) + (eq (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 (eq ret (foo1-a (foo1-a ret))) + (eq (foo1-a ret) + (foo1-a (foo1-a (foo1-a ret))))))) t) -(defclass foobarbaz () ((x :accessor x :initarg :x))) +(defclass random-obj () ((size :accessor size :initarg :size))) -(defstore (obj foobarbaz buff) - (store-object (x obj) buff)) - -;(defstore (obj foobarbaz buff :before) -; (format t "Storing a foobarbaz object.")) - -(defrestore (foobarbaz buff) - (make-instance 'foobarbaz :x (restore-object buff))) +(defvar *random-obj-code* (register-code 22 'random-obj)) +(defstore-cl-store (obj random-obj buff) + (output-type-code *random-obj-code* buff) + (store-object (size obj) buff)) -(deftest custom.1 - (progn (store (make-instance 'foobarbaz :x "foo") *test-file*) - (equal "foo" (x (restore *test-file*)))) - t) +(defrestore-cl-store (random-obj buff) + (random (restore-object buff))) -(defclass random-obj () ((size :accessor size :initarg :size))) -(defstore (obj random-obj buff :type-code 10232) - (store-object (size obj) buff)) +(add-xml-mapping "RANDOM-OBJ") +(defstore-xml (obj random-obj stream) + (princ-and-store "RANDOM-OBJ" (size obj) stream)) -(defrestore (random-obj buff) - (random (restore-object buff))) +(defrestore-xml (random-obj stream) + (random (restore-first stream))) -(deftest custom.2 - (progn (store (make-instance 'random-obj :size 5) *test-file*) +(deftest custom.1 + (progn (store (make-instance 'random-obj :size 5) *test-file* ) (typep (restore *test-file*) '(integer 0 4))) t) (defun run-tests () - (regression-test:do-tests) + (format t "~&RUNNING TESTS USING CL-STORE-BACKEND~%") + (with-backend (cl-store) + (regression-test:do-tests)) + (format t "~&RUNNING TESTS USING XML-BACKEND~%") + (with-backend (xml) + (regression-test:do-tests)) (when (probe-file *test-file*) (delete-file *test-file*))) Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.7 cl-store/package.lisp:1.8 --- cl-store/package.lisp:1.7 Sat Jun 5 04:56:42 2004 +++ cl-store/package.lisp Tue Aug 17 04:12:43 2004 @@ -1,119 +1,138 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. - -(defpackage :cl-store - (:use :cl) - (:export :store - :restore - :defstore - :defrestore - :store-error - :restore-error - :internal-store-object - :store-non-return - :store-executable - :store-object - :restore-object - :register-code - :flush - :fill-buffer - :make-buffer - :*full-write* - :*store-class-slots* - :*nuke-existing-classes* - :*store-class-superclasses*) - #+sbcl (:import-from :sb-mop - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - 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) +(defpackage #:cl-store + (:use #:cl) + (:export #:backend + #:name + #:magic-number + #:stream-type + #:restorer-funs + #:restorers + #:find-backend + #:defbackend + #:with-backend + #:fix-circularities + #:*default-backend* + #:*cl-store-backend* + #:*current-backend* + #:*store-class-slots* + #:*nuke-existing-classes* + #:*store-class-superclasses* + #:store-error + #:restore-error + #:store + #:restore + #:backend-store + #:check-stream-element-type + #:store-backend-code + #:store-object + #:backend-store-object + #:get-class-details + #:get-array-values + #:restore + #:backend-restore + #:check-magic-number + #:get-next-reader + #:restore-object + #:backend-restore-object + #:cl-store + #:defstore-cl-store + #:defrestore-cl-store + #:register-code + #:output-type-code + #:xml) + #+sbcl (:import-from #:sb-mop + #:slot-definition-name + #:slot-value-using-class + #:slot-boundp-using-class + #:slot-definition-allocation + #: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) + + #+cmu (:import-from #:pcl + #:slot-definition-name + #:slot-value-using-class + #:slot-boundp-using-class + #:slot-definition-allocation + #: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) + + #+cmu (:shadowing-import-from #:pcl + #:class-name + #:find-class + #:standard-class + #:class-of) + + #+openmcl (:import-from #:openmcl-mop + #:slot-definition-name + #:slot-value-using-class + #:slot-boundp-using-class + #:slot-definition-allocation + #: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) - #+cmu (:import-from :pcl - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - 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) + #+clisp (:import-from #:clos + #:slot-value + #:std-compute-slots + #:slot-boundp + #:class-name + #:class-direct-default-initargs + #:class-direct-slots + #:class-slots + #:ensure-class) - #+cmu (:shadowing-import-from :pcl - class-name - find-class - standard-class - class-of) - - #+openmcl (:import-from :openmcl-mop - slot-definition-name - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - 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) - - #+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 - slot-value-using-class - slot-boundp-using-class - slot-definition-allocation - 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-slots - class-direct-superclasses - ensure-class)) + #+lispworks (:import-from #:clos + #:slot-definition-name + #:slot-value-using-class + #:slot-boundp-using-class + #:slot-definition-allocation + #: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-slots + #:class-direct-superclasses + #:ensure-class)) ;; package used to unclutter cl-store by holding all %referrer symbols. -(defpackage :cl-store-referrers) +(defpackage #:cl-store-referrers) -;; EOF +;; EOF \ No newline at end of file Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.4 cl-store/cl-store.asd:1.5 --- cl-store/cl-store.asd:1.4 Fri Jun 4 06:55:33 2004 +++ cl-store/cl-store.asd Tue Aug 17 04:12:43 2004 @@ -1,11 +1,12 @@ ;;; -*- 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)) +(defpackage #:cl-store.system + (:use #:cl #:asdf)) -(in-package :cl-store.system) +(in-package #:cl-store.system) (defclass non-required-file (cl-source-file) () (:documentation @@ -35,33 +36,44 @@ (defsystem cl-store - :name "Store" + :name "CL-STORE" :author "Sean Ross <sdr@jhb.ucs.co.za>" :maintainer "Sean Ross <sdr@jhb.ucs.co.za>" - :version "0.1.3" + :version "0.2" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" :components ((:file "package") - (:file "fast-io" :depends-on ("package")) - (:file "utils" :depends-on ("fast-io")) (:non-required-file "fix-clisp" :depends-on ("package")) - (:file "circularities" :depends-on ("utils")) - (:file "store" :depends-on ("circularities")) - (:non-required-file "sockets" :depends-on ("store"))) - :depends-on (#+sbcl :sb-bsd-sockets)) + (:file "utils" :depends-on ("package")) + (:file "backends" :depends-on ("utils")) + (:file "plumbing" :depends-on ("backends")) + (:file "circularities" :depends-on ("plumbing")) + (:file "default-backend" :depends-on ("circularities")))) + +(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" + :licence "MIT" + :components ((:file "xml-backend")) + :depends-on (:cl-store :xmls)) (defmethod perform :after ((o load-op) (c (eql (find-system :cl-store)))) (provide 'cl-store)) +(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)))) (oos 'load-op :cl-store-tests) (oos 'test-op :cl-store-tests)) (defsystem cl-store-tests - :depends-on (rt) + :depends-on (rt cl-store cl-store-xml) :components ((:file "tests"))) (defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests)))) @@ -69,4 +81,4 @@ (error "Test-op Failed."))) -;; EOF +;; EOF \ No newline at end of file Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.4 cl-store/circularities.lisp:1.5 --- cl-store/circularities.lisp:1.4 Fri Jun 4 06:55:33 2004 +++ cl-store/circularities.lisp Tue Aug 17 04:12:43 2004 @@ -1,155 +1,216 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. -(in-package :cl-store) - -(defvar *referrer-string* "%REFERRER-") -(defvar *stored-values* nil) -(declaim (type fixnum *stored-counter*)) -(defvar *stored-counter* 0) -(defvar *seen-while-fixing* nil) +;; 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) +(declaim (optimize (speed 3) (safety 0) (debug 0))) -(defun referrerp (sym) - (and (symbolp sym) - (eq (symbol-package sym) #.(find-package :cl-store-referrers)) - (equal (subseq (symbol-name sym) 0 10) +(defvar *referrer-string* "%%Referrer-" + "String which will be interned to create a symbol we + can recognize as a referrer.") + +(defvar *prefix-setters* + '(slot-value aref row-major-aref) + "Setfable places which take the object to set before the + rest of the arguments.") + +(defun get-setf-place (place obj) + "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*." + (declare (type (or cons symbol) place)) + (cond ((atom place) `(,place ,obj)) + ((member (car place) *prefix-setters*) + `(,(car place) ,obj ,@(cdr place))) + (t `(,@place ,obj)))) + + +;; 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)) + (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.")) + + +(defmacro resolving-object (create &body body) + "Execute body attempting to resolve circularities found in + form CREATE." + (with-gensyms (obj value key) + `(macrolet ((setting (place getting) + (let ((setf-place (get-setf-place place ',obj))) + `(let ((,',value ,getting)) + (if (referrerp ,',value) + (push (lambda () + (setf ,setf-place + (referred-value ,',value + *restored-values*))) + *need-to-fix*) + (setf ,setf-place ,',value))))) + (setting-hash (getting-key getting-place) + `(let ((,',key ,getting-key)) + (if (referrerp ,',key) + (let ((,',value ,getting-place)) + (push (lambda () + (setf (gethash + (referred-value ,',key *restored-values*) + ,',obj) + (if (referrerp ,',value) + (referred-value ,',value + *restored-values*) + ,',value))) + *need-to-fix*)) + (setting (gethash ,',key) ,getting-place))))) + (let ((,obj ,create)) + ,@body + ,obj)))) + +(defun referrerp (val) + "Is val a referrer?" + (and (symbolp val) + (eq (symbol-package val) #.(find-package :cl-store-referrers)) + (equal (subseq (symbol-name val) 0 11) *referrer-string*))) (defun referred-value (referrer hash) - (gethash (read-from-string (subseq (symbol-name referrer) 10)) + "Return the value REFERRER is meant to be by looking in HASH." + (gethash (read-from-string (subseq (symbol-name referrer) 11)) hash)) -(defgeneric inner-fix-circularities (hash obj)) +(defun make-referrer (x) + "Create a new referrer suffixed with X." + (declare (type fixnum x)) + (let ((name (intern (format nil "%%Referrer-~D" x) + :cl-store-referrers))) + name)) -(defun fix-circularities (val1 val2 ) - (aif (gethash val2 *seen-while-fixing*) - nil - (progn (setf (gethash val2 *seen-while-fixing*) t) - (inner-fix-circularities val1 val2)))) - - -;; hash tables and objects require some extra fiddling. -(defmethod inner-fix-circularities ((hash hash-table) (obj hash-table)) - (fix-circularities hash nil) - (loop for key being the hash-keys of obj - for val being the hash-values of obj do - (fix-circularities hash key) - (fix-circularities hash val) - (when (referrerp val) - (setf (gethash key obj) - (referred-value val hash))))) - -(defmethod inner-fix-circularities ((hash hash-table) (obj standard-class)) - nil) - - -(defmethod inner-fix-circularities ((hash hash-table) (obj standard-object)) - (fix-circularities hash nil) - (dolist (slot (mapcar #'slot-definition-name - (class-slots (class-of obj)))) - (when (slot-boundp obj slot) - (fix-circularities hash (slot-value obj slot)) - (when (referrerp (slot-value obj slot)) - (setf (slot-value obj slot) - (referred-value (slot-value obj slot) hash)))))) - -(defmethod inner-fix-circularities ((hash hash-table) (obj structure-object)) - (fix-circularities hash nil) - (dolist (slot (mapcar #'slot-definition-name - (class-slots (class-of obj)))) - (when (slot-boundp obj slot) - (fix-circularities hash (slot-value obj slot)) - (when (referrerp (slot-value obj slot)) - (setf (slot-value obj slot) - (referred-value (slot-value obj slot) hash)))))) - - -(defmethod inner-fix-circularities ((hash hash-table) obj) - (loop for counter from 1 to (hash-table-count hash) do - (let ((ref (gethash counter hash)) - changed) - (when (referrerp ref) - (setf (gethash counter hash) - (referred-value ref hash))) - (awhen (and (or (typep ref 'sequence) - (arrayp ref)) - (pos-of ref)) - (cond - ((eq it :last) - (setf changed t) - (setf (cdr (last ref)) - (referred-value (cdr (last ref)) hash))) - ((and (listp ref) (numberp it)) - (setf changed t) - (setf (nth it ref) - (referred-value (nth it ref) hash))) - ((and (arrayp ref) (numberp it)) - (setf changed t) - (setf (row-major-aref ref it) - (referred-value (row-major-aref ref it) hash))) - (t nil))) - (when changed - ;; lets be sure. - (fix-circularities hash obj))))) - - -(defun ref-name (x) - (intern (format nil "%REFERRER-~D" x) - :cl-store-referrers)) - - -(defun pos-of (sequence) - "Like position but it doens't choke on dotted lists" - (when (and (listp sequence) - (circular-listp sequence)) - (return-from pos-of nil)) - (labels ((inner (sequence counter) - (cond ((atom sequence) - (when (referrerp sequence) - :last)) - ((referrerp (car sequence)) - counter) - (t (inner (cdr sequence) (1+ counter))))) - (inner-array () - (loop for x from 0 upto (1- (array-total-size sequence)) do - (if (referrerp (row-major-aref sequence x)) - (return-from inner-array x))))) - (cond ((and (listp sequence) - (atom (cdr (last sequence)))) - (inner sequence 0)) - ((vectorp sequence) - (position-if #'referrerp sequence)) - ((arrayp sequence) - (inner-array))))) -;; storing already seen objects +(defclass resolving-backend (backend) + () + (:documentation "A backend which does the setup for resolving circularities.")) + +(declaim (type fixnum *stored-counter*)) +(defvar *stored-counter*) +(defvar *stored-values*) + +(defmethod backend-store ((obj t) (place t) (backend resolving-backend)) + "Store OBJ into PLACE. Does the setup for counters and seen values." + (let ((*stored-counter* 0) + (*stored-values* (make-hash-table :test #'eq))) + (check-stream-element-type place backend) + (store-backend-code place backend) + (backend-store-object obj place backend) + obj)) (defun seen (obj) + "Has this object already been stored?" + (incf *stored-counter*) (gethash obj *stored-values*)) (defun update-seen (obj) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (setf (gethash obj *stored-values*) (incf *stored-counter*)) + "Register OBJ as having been stored." + (setf (gethash obj *stored-values*) *stored-counter*) obj) +(deftype not-circ () + "Type grouping integer, characters and symbols, which we + don't bother to check if they have been stored before" + '(or integer character symbol)) + (defun needs-checkp (obj) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (not (or (typep obj 'integer) - (symbolp obj) - (characterp obj)))) - -;; instead of constructing symbols here we rather -;; just return a second value indicating we have -;; seen this object before and avoid interning unnecessary symbols -(defun real-value (obj) - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) + "Do we need to check if this object has been stored before?" + (not (typep obj 'not-circ))) + +(defun value-or-referrer (obj) + "Returns the number of the referrer and t if this object + has already been stored in this STORE call." (if (needs-checkp obj) (aif (seen obj) (values it t) (values (update-seen obj) nil)) obj)) -;; EOF +(defgeneric store-referrer (obj place backend) + (:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.") + (:method ((obj t) (place t) (backend resolving-backend)) + (store-error "store-referrer must be specialized for backend ~(~A~)." + (name backend)))) + +(defmethod backend-store-object ((obj t) (place t) (backend resolving-backend)) + "Store object if we have not seen this object before, otherwise retrieve + the referrer object for it and store that using store-referrer." + (multiple-value-bind (obj referrerp) (value-or-referrer obj) + (if referrerp + (store-referrer obj place backend) + (internal-store-object obj place backend)))) + + + +;; Restoration. +(declaim (type fixnum *restore-counter*)) +(defvar *restore-counter*) +(defvar *need-to-fix*) +(defvar *restored-values*) + +(defmethod backend-restore ((place stream) (backend resolving-backend)) + "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* (make-hash-table))) + (check-stream-element-type place backend) + (check-magic-number place backend) + (let ((obj (backend-restore-object place backend))) + (dolist (fn *need-to-fix*) + (funcall (the function fn))) + obj))) + +(defmethod backend-restore-object ((place t) (backend resolving-backend)) + "Retrieve a object from PLACE, does housekeeping for circularity fixing." + (let ((reader (find-function-for-type place backend))) + (if (not (int-sym-or-char-p reader backend)) + (setf (gethash (incf *restore-counter*) *restored-values*) + (new-val (funcall (the function reader) place))) + (funcall (the function reader) place)))) + +(defun int-sym-or-char-p (fn backend) + "Is function FN registered to restore an integer, character or symbol + in BACKEND." + (let ((readers (restorer-funs backend))) + (or (eq fn (lookup-reader 'integer readers)) + (eq fn (lookup-reader 'character readers)) + (eq fn (lookup-reader 'symbol readers))))) + + +(defun new-val (val) + "Tries to get a referred value to reduce unnecessary cirularity fixing." + (if (referrerp val) + (aif (referred-value val *restored-values*) + it + val) + val)) + +;; EOF \ No newline at end of file Index: cl-store/README diff -u cl-store/README:1.3 cl-store/README:1.4 --- cl-store/README:1.3 Sat Jun 5 04:56:42 2004 +++ cl-store/README Tue Aug 17 04:12:43 2004 @@ -1,6 +1,7 @@ -Readme for Package CL-STORE. +README for Package CL-STORE. Author: Sean Ross Homepage: http://www.common-lisp.net/project/cl-store/ +Version: 0.2 0. About. CL-STORE is an portable serialization package which @@ -9,29 +10,36 @@ 1. Installation. - The first thing you need is a common-lisp, CL-STORE currently - supports SBCL, CMUCL, Lispworks and CLISP. + The first thing you need is a common-lisp, CL-STORE currently + supports SBCL, CMUCL, Lispworks, CLISP and OpenMCL. - Hopefully you've asdf-install to install this in which case - all should be fine. + Hopefully you've asdf-install to install this in which case + all should be fine. - Otherwise symlink cl-store.asd to somewhere on asdf:*central-registry* - and run (asdf:oos 'asdf:load-op :cl-store). + Otherwise symlink cl-store.asd to somewhere on asdf:*central-registry* + and run (asdf:oos 'asdf:load-op :cl-store). - Run (asdf:oos 'asdf:test-op :cl-store) to make sure that - everything works. Running these tests will try to - load the RT package, which is asdf-installable. - If anything breaks drop me a line, see - http://www.common-lisp.net/project/cl-store/ for mailing-lists. + The xml backend can be loaded with (asdf:oos 'asdf:loaded :cl-store-xml). + This requires xmls which can be found on http://www.cliki.net and + is asdf-installable. + + Run (asdf:oos 'asdf:test-op :cl-store) to make sure that + everything works. Running these tests will try to + load the RT package, which is asdf-installable. + If anything breaks drop me a line, see + http://www.common-lisp.net/project/cl-store/ for mailing-lists. 2. Usage The two main entry points are - - cl-store:store obj place => obj - Where place is a path designator, stream or socket. - - - cl-store:restore place => restored-obj - Where place is as above. + - cl-store:store (obj place &optional (backend *default-backend*)) i + => obj + Where place is a path designator, stream or socket and + backend is one of the registered backend. + + - cl-store:restore (place &optional (backend *default-backend*)) + => restored-obj + Where place and backend is as above. - cl-store:restore is setfable, which I think makes for a great serialized hit counter. @@ -39,43 +47,54 @@ 3. Extending - CL-STORE is more or less extensible. Using defstore and defrestore - allows you to customize the storing and restoring of your own classes. + CL-STORE is more or less extensible. Using defstore-<backend-name> + and defrestore-<backend-name> allows you to customize the storing + and restoring of your own classes. + contrived eg. - - (defclass random () ((a :accessor a :initarg :a))) - (defstore (obj random buffer) - (store-object (a obj) buffer)) + (in-package :cl-user) + + (use-package :cl-store) + + (defclass random-obj () ((a :accessor a :initarg :a))) + + (defvar *random-obj-code* (register-code 22 'random-obj)) - (defrestore (random buff) - (random (restore-object buff))) + (defstore-cl-store (obj random-obj stream) + (output-type-code *random-obj-code* stream) + (store-object (a obj) stream)) - (store (make-instance 'random :a 10) "/tmp/random") + (defrestore-cl-store (random-obj stream) + (random (restore-object stream))) + + (store (make-instance 'random-obj :a 10) "/tmp/random") (restore "/tmp/random") => ; some number from 0 to 9 + + +4. Backends + CL-STORE now has a concept of backends, suggested by Robert Sedgewick. + Two backends are in releases now, a default backend which is much + what cl-store used to be (pre 0.2) and an xml backend which writes out + xml to character streams. + Store and Restore now take an optional backend argument which + currently can be one of *default-backend* or *xml-backend*. + + The xml written out is not very human readable. + I recommend using a tool like tidy <http://tidy.sourceforge.net/> + to view it in a nice format. + - -4. Issues - There are a number of issues with CL-STORE as it stands (0.1.3). +5. Issues + There are a number of issues with CL-STORE as it stands (0.2). - Functions, closures and anything remotely funcallable is unserializable. - MOP classes are largely unsupported at the moment. - Structure instances are not supported in anything but CMUCL and SBCL. - Structure definitions aren't supported at all. - - The code for resolving object circularities is a touch dodgy, - hopefully a better way will be found at some point. - No documentation. - - CL-STORE uses read-sequence to pull values out of streams. Unfortunately - read-sequence doesn't just block but waits until the entire - buffer is filled. As a quick workaround the evil variable *full-write* - was created to force write-sequence to write the entire buffer - down the stream. Setting this to nil is a good idea if you are - working with file streams. If you are working with streams - created from sockets DO NOT set *full-write* to nil as this - will invariably hang. This has been resolved for SBCL and - you can store and restore objects directly to and from sockets. - Older cmucl versions, where (eq 'cl:class 'pcl::class) returns nil, cannot store classes obtained using cl:find-class. The solution for this is to use pcl::find-class. @@ -83,5 +102,3 @@ Enjoy Sean. - - Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.4 cl-store/ChangeLog:1.5 --- cl-store/ChangeLog:1.4 Fri Jun 4 06:55:33 2004 +++ cl-store/ChangeLog Tue Aug 17 04:12:43 2004 @@ -1,22 +1,36 @@ +2004-07-29 Sean Ross <sdr@jhb.ucs.co.za> + * 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 <sdr@jhb.ucs.co.za> - * circularities.lisp: spelling fix. - * cl-store.asd: Specialized operation-done-p to stop some errors. - * package.lisp: Imports for openmcl from Robert Sedgewick, - Along with extra imports for cmucl. + * 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 <sdr@jhb.ucs.co.za> - * 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. + * 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 <sdr@jhb.ucs.co.za> - * 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 + * 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 <sdr@jhb.ucs.co.za> * store.lisp, fast-io.lisp, circularities.lisp, package.lisp, - fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp: - Initial import + fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp: + Initial import Index: cl-store/.cvsignore diff -u cl-store/.cvsignore:1.1.1.1 cl-store/.cvsignore:1.2 --- cl-store/.cvsignore:1.1.1.1 Mon May 17 08:41:19 2004 +++ cl-store/.cvsignore Tue Aug 17 04:12:43 2004 @@ -1,6 +1,6 @@ *.fasl *.x86f *.ufsl -filetest.dat +filetest.cls *.fas *.lib