X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=3182342bd68e91b78dab746ba0c82aac2b7e47ce;hb=HEAD;hp=be5e67740b61e260888b4c3cce4ea6d3c2c30162;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index be5e677..3182342 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -31,6 +31,35 @@
 ;;; a "contrib" directory eventually?
 
 #|
+(defun parse-method-or-spec (spec &optional (errorp t))
+  (let (gf method name temp)
+    (if (method-p spec)
+        (setq method spec
+              gf (method-generic-function method)
+              temp (and gf (generic-function-name gf))
+              name (if temp
+                       (make-method-spec temp
+                                         (method-qualifiers method)
+                                         (unparse-specializers
+                                          (method-specializers method)))
+                       (make-symbol (format nil "~S" method))))
+        (let ((gf-spec (car spec)))
+          (multiple-value-bind (quals specls)
+              (parse-defmethod (cdr spec))
+            (and (setq gf (and (or errorp (fboundp gf-spec))
+                               (gdefinition gf-spec)))
+                 (let ((nreq (compute-discriminating-function-arglist-info gf)))
+                   (setq specls (append (parse-specializers specls)
+                                        (make-list (- nreq (length specls))
+                                                   :initial-element
+                                                   *the-class-t*)))
+                   (and
+                    (setq method (get-method gf quals specls errorp))
+                    (setq name
+                          (make-method-spec
+                           gf-spec quals (unparse-specializers specls)))))))))
+    (values gf method name)))
+
 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
 ;;; method-spec should be a list like:
 ;;;   (<generic-function-spec> qualifiers* (specializers*))
@@ -108,15 +137,19 @@
   (fdefinition name))
 |#
 
+#|
 ;;;; Helper for slightly newer trace implementation, based on
 ;;;; breakpoint stuff.  The above is potentially still useful, so it's
 ;;;; left in, commented.
+
+;;; (this turned out to be a roundabout way of doing things)
 (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)))))
+|#
 
 ;;;; MAKE-LOAD-FORM
 
@@ -144,33 +177,35 @@
 
 (defmethod make-load-form ((object structure-object) &optional env)
   (declare (ignore env))
-  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+  (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).~@>"
+  (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).~@>"
+  (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)
+(defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) 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)
+                    (and (not slot-names-p)
                          (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)))
+                      ;; FIXME: why not go class->layout->info == dd?
+                      (let* ((dd (find-defstruct-description
+                                  (class-name class)))
                              (dsd (find slot-name (dd-slots dd)
                                         :key #'dsd-name)))
                         (inits `(,(slot-setter-lambda-form dd dsd)