[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp

[Sean Ross]

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