Update of /project/cl-store/cvsroot/cl-store/cmucl In directory common-lisp.net:/tmp/cvs-serv20044/cmucl Modified Files: custom.lisp Log Message: Added structure definition support for CMUCL Date: Fri Nov 26 15:35:52 2004 Author: sross Index: cl-store/cmucl/custom.lisp diff -u cl-store/cmucl/custom.lisp:1.3 cl-store/cmucl/custom.lisp:1.4 --- cl-store/cmucl/custom.lisp:1.3 Wed Nov 24 14:27:12 2004 +++ cl-store/cmucl/custom.lisp Fri Nov 26 15:35:51 2004 @@ -36,4 +36,100 @@ (restore-type-object stream)) + + +;; Structure definitions +(defun get-layout (obj) + (slot-value obj 'pcl::wrapper)) + +(defun get-info (obj) + (declare (type kernel:layout obj)) + (slot-value obj 'ext:info)) + +(defun dd-name (dd) + (slot-value dd 'kernel::name)) + +(defvar *cmucl-struct-inherits* + (list (get-layout (find-class t)) + (get-layout (find-class 'kernel:instance)) + (get-layout (find-class 'cl:structure-object)))) + +(defstruct (struct-def (:conc-name sdef-)) + (supers (required-arg :supers) :type list) + (info (required-arg :info) :type kernel:defstruct-description)) + +(defun info-or-die (obj) + (let ((wrapper (get-layout obj))) + (if wrapper + (or (get-info wrapper) + (store-error "No defstruct-definition for ~A." obj)) + (store-error "No wrapper for ~A." obj)))) + +(defun save-able-supers (obj) + (set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits) + 'list) + *cmucl-struct-inherits*)) + +(defun get-supers (obj) + (loop for x in (save-able-supers obj) + collect (let ((name (dd-name (get-info x)))) + (if *store-class-superclasses* + (find-class name) + name)))) + +(defstore-cl-store (obj structure-class stream) + (output-type-code +structure-class-code+ stream) + (store-object (make-struct-def :info (info-or-die obj) + :supers (get-supers obj)) + stream)) + +(defstore-cl-store (obj struct-def stream) + (output-type-code +struct-def-code+ stream) + (store-object (sdef-supers obj) stream) + (store-object (sdef-info obj) stream)) + +;; Restoring +(defun cmu-struct-defs (dd) + (append (kernel::define-constructors dd) + (kernel::define-raw-accessors dd) + (kernel::define-class-methods dd))) + +(defun create-make-foo (dd) + (dolist (x (cmu-struct-defs dd)) + (eval x)) + (find-class (dd-name dd))) + +(defun cmu-define-structure (dd supers) + (cond ((or *nuke-existing-classes* + (not (find-class (dd-name dd) nil))) + ;; create-struct + (kernel::%defstruct dd supers) + ;; compiler stuff + ;;(kernel::%compiler-defstruct dd) + ;; create make-? + (create-make-foo dd)) + (t (find-class (dd-name dd))))) + +(defun super-layout (super) + (etypecase super + (symbol (get-layout (find-class super))) + (structure-class + (super-layout (dd-name (info-or-die super)))))) + +(defun super-layouts (supers) + (loop for super in supers + collect (super-layout super))) + +(defrestore-cl-store (structure-class stream) + (restore-object stream)) + +(defrestore-cl-store (struct-def stream) + (let* ((supers (super-layouts (restore-object stream))) + (dd (restore-object stream))) + (cmu-define-structure dd (if supers + (coerce (append *cmucl-struct-inherits* + supers) + 'vector) + (coerce *cmucl-struct-inherits* 'vector))))) + ;; EOF