Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv15959/sbcl

Modified Files: custom.lisp Log Message: Changelog 2004-11-24 (0.4 Release) Date: Wed Nov 24 14:27:23 2004 Author: sross

Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.3 cl-store/sbcl/custom.lisp:1.4 --- cl-store/sbcl/custom.lisp:1.3 Wed Nov 10 11:43:33 2004 +++ cl-store/sbcl/custom.lisp Wed Nov 24 14:27:22 2004 @@ -2,10 +2,11 @@ ;; See the file LICENCE for licence information.

(in-package :cl-store) +;; TODO +;; real Functions and closures.

;; Custom float storing - (defstore-cl-store (obj float stream) (output-type-code +float-code+ stream) (write-byte (float-type obj) stream) @@ -24,17 +25,11 @@ (sb-kernel:make-double-float (the integer (restore-object stream)) (the integer (restore-object stream))))

-(defvar *sbcl-float-restorers* - (list (cons 0 #'sbcl-restore-single-float) - (cons 1 #'sbcl-restore-double-float))) - (defrestore-cl-store (float stream) (let ((byte (read-byte stream))) - (declare (type (integer 0 1) byte)) - (aif (cdr (assoc byte *sbcl-float-restorers* :test #'=)) - (funcall (the function it) stream) - (restore-error "Unknown float type designator ~S." byte)))) - + (ecase byte + (0 (sbcl-restore-single-float stream)) + (1 (sbcl-restore-double-float stream)))))

;; Custom structure storing (defstore-cl-store (obj structure-object stream) @@ -44,5 +39,100 @@ (defrestore-cl-store (structure-object stream) (restore-type-object stream))

+ +;; Structure definition storing +(defun get-layout (obj) + (slot-value obj 'sb-pcl::wrapper)) + +(defun get-info (obj) + (declare (type sb-kernel:layout obj)) + (slot-value obj 'sb-int:info)) + +(defun dd-name (dd) + (slot-value dd 'sb-kernel::name)) + +(defvar *sbcl-struct-inherits* + (list (get-layout (find-class t)) + (get-layout (find-class 'sb-kernel:instance)) + (get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type sb-kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'sb-kernel::inherits) + 'list) + *sbcl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring + +(defun sbcl-struct-defs (info) + (append (sb-kernel::constructor-definitions info) + (sb-kernel::class-method-definitions info))) + +(defun create-make-foo (dd) + (dolist (x (sbcl-struct-defs dd)) + (eval x)) + (find-class (dd-name dd))) + + +(defun sbcl-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (sb-kernel::%defstruct dd supers) + ;; compiler stuff + (sb-kernel::%compiler-defstruct dd supers) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (sbcl-define-structure dd (if supers + (coerce (append *sbcl-struct-inherits* + supers) + 'vector) + (coerce *sbcl-struct-inherits* 'vector)))))

;; EOF