;;; 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))))
+ (multiple-value-bind (gf-spec quals specls)
+ (parse-defmethod 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*))
(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.
+
+;;; (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)))))
+|#
\f
;;;; MAKE-LOAD-FORM
(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)