X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=d793f9a528c9928d7057198cc4f6d7c86f4a3c97;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=bf41126775b2bb4f7646e59736107a82290688ed;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index bf41126..d793f9a 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -125,40 +125,40 @@
 
 (defmethod make-load-form ((object wrapper) &optional env)
   (declare (ignore env))
-  (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
+  (let ((pname (classoid-proper-name
+		(layout-classoid object))))
     (unless pname
       (error "can't dump wrapper for anonymous class:~%  ~S"
-	     (sb-kernel:layout-class object)))
-    `(sb-kernel:class-layout (cl:find-class ',pname))))
-
-;;;; The following are hacks to deal with CMU CL having two different CLASS
-;;;; classes.
-
-(defun coerce-to-pcl-class (class)
-  (if (typep class 'cl:class)
-      (or (sb-kernel:class-pcl-class class)
-	  (find-structure-class (cl:class-name class)))
-      class))
-
-(defmethod make-instance ((class cl:class) &rest stuff)
-  (apply #'make-instance (coerce-to-pcl-class class) stuff))
-(defmethod change-class (instance (class cl:class))
-  (apply #'change-class instance (coerce-to-pcl-class class)))
-
-(macrolet ((frob (&rest names)
-	     `(progn
-		,@(mapcar (lambda (name)
-			    `(defmethod ,name ((class cl:class))
-			       (funcall #',name
-					(coerce-to-pcl-class class))))
-			  names))))
-  (frob
-    class-direct-slots
-    class-prototype
-    class-precedence-list
-    class-direct-default-initargs
-    class-direct-superclasses
-    compute-class-precedence-list
-    class-default-initargs class-finalized-p
-    class-direct-subclasses class-slots
-    make-instances-obsolete))
+	     (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)))
+                  (inits `(setf (slot-value ,object ',slot-name) ',value)))
+                (inits `(slot-makunbound ,object ',slot-name))))))
+      (values `(allocate-instance (find-class ',(class-name class)))
+              `(progn ,@(inits))))))