0.9.2.38: thread cleanup, paranoid

[sbcl.git] / src / pcl / env.lisp

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index 359ad30..fadcb93 100644 (file)
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -108,6 +108,16 @@
   (fdefinition name))
 |#
 \f
+;;;; Helper for slightly newer trace implementation, based on
+;;;; breakpoint stuff.  The above is potentially still useful, so it's
+;;;; left in, commented.
+(defun list-all-maybe-method-names (gf)
+  (let (result)
+    (dolist (method (generic-function-methods gf) (nreverse result))
+      (let ((spec (nth-value 2 (parse-method-or-spec method))))
+        (push spec result)
+        (push (list* 'fast-method (cdr spec)) result)))))
+\f
 ;;;; MAKE-LOAD-FORM
 
 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
@@ -132,3 +142,40 @@
             (layout-classoid object)))
     `(classoid-layout (find-classoid ',pname))))
 
+(defmethod make-load-form ((object structure-object) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defmethod make-load-form ((object standard-object) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defmethod make-load-form ((object condition) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defun make-load-form-saving-slots (object &key slot-names environment)
+  (declare (ignore environment))
+  (let ((class (class-of object)))
+    (collect ((inits))
+      (dolist (slot (class-slots class))
+        (let ((slot-name (slot-definition-name slot)))
+          (when (or (memq slot-name slot-names)
+                    (and (null slot-names)
+                         (eq :instance (slot-definition-allocation slot))))
+            (if (slot-boundp-using-class class object slot)
+                (let ((value (slot-value-using-class class object slot)))
+                 (if (typep object 'structure-object)
+                     ;; low-level but less noisy initializer form
+                     (let* ((dd (get-structure-dd (class-name class)))
+                            (dsd (find slot-name (dd-slots dd)
+                                       :key #'dsd-name)))
+                       (inits `(,(slot-setter-lambda-form dd dsd)
+                                ',value ,object)))
+                     (inits `(setf (slot-value ,object ',slot-name) ',value))))
+                (inits `(slot-makunbound ,object ',slot-name))))))
+      (values `(allocate-instance (find-class ',(class-name class)))
+              `(progn ,@(inits))))))