X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=d074eb63fa8c3ca83ea29596f4112444c4480901;hb=add57c72c932fbf70c8ba8297154936c908b410e;hp=90c8f38a18c8d33751b56fca1fe1b4181f5557f8;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index 90c8f38..d074eb6 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -28,7 +28,7 @@
 ;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
 ;;; exported from PCL, but it looks as though it might be useful,
 ;;; so I don't want to just delete it. Perhaps it should go in
-;;; a contrib/ directory eventually?
+;;; a "contrib" directory eventually?
 
 #|
 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
@@ -103,9 +103,9 @@
 
 (defun trace-method-internal (ofunction name options)
   (eval `(untrace ,name))
-  (setf (symbol-function name) ofunction)
+  (setf (fdefinition name) ofunction)
   (eval `(trace ,name ,@options))
-  (symbol-function name))
+  (fdefinition name))
 |#
 
 ;;;; MAKE-LOAD-FORM
@@ -125,40 +125,47 @@
 
 (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)))
+		  (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))))))